Tcl Source Code

Check-in [e4761eb0a8]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Backport "registry" version 1.3.3, so all active branches now have the same registry version. (this commit must -eventually- be merge-marked to core-8-6-branch, since everything is there already)
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | core-8-5-branch
Files: files | file ages | folders
SHA3-256: e4761eb0a8434af30ea554566d851b67ae0ac920889482c323d18ef6fcd70549
User & Date: jan.nijtmans 2018-10-24 21:22:18.670
Context
2018-10-27
07:53
tclWinDde.c: Backport version 1.4.1 from Tcl 8.6. check-in: 714f445acf user: jan.nijtmans tags: core-8-5-branch
2018-10-24
21:22
Backport "registry" version 1.3.3, so all active branches now have the same registry version. (this... check-in: e4761eb0a8 user: jan.nijtmans tags: core-8-5-branch
2018-10-23
11:14
Enable CI builds with Travis. check-in: 0386db909a user: dkf tags: core-8-5-branch
Changes
Side-by-Side Diff Ignore Whitespace Patch
Changes to library/reg/pkgIndex.tcl.
1
2
3
4
5


6
7
8


9
1
2
3


4
5
6


7
8
9



-
-
+
+

-
-
+
+

if {![package vsatisfies [package provide Tcl] 8]} return
if {[info sharedlibextension] != ".dll"} return
if {[info exists ::tcl_platform(debug)]} {
    package ifneeded registry 1.2.2 \
            [list load [file join $dir tclreg12g.dll] registry]
    package ifneeded registry 1.3.3 \
            [list load [file join $dir tclreg13g.dll] registry]
} else {
    package ifneeded registry 1.2.2 \
            [list load [file join $dir tclreg12.dll] registry]
    package ifneeded registry 1.3.3 \
            [list load [file join $dir tclreg13.dll] registry]
}
Changes to tests/registry.test.
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
30
31
32
33




34
35
36







37
38
39



40
41
42
43






44
45
46
47
48
49
50
51
52
53






54
55
56
57
58
59
60
61
62
63
64
65
66






67
68
69
70
71
72
73
74
75
76






77
78
79
80
81
82
83
84
85
86
87
88
89






90
91
92
93
94
95
96
97
98
99
100
101
102






103
104
105
106
107
108
109
110
111
112
113
114

115
116
117

118
119
120
121
122
123
124
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32

33
34
35
36
37
38

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161

162
163
164

165
166
167
168
169
170
171
172







-
+










-
+
+
+
+


-
+
+
+
+
+
+
+



+
+
+




+
+
+
+
+
+










+
+
+
+
+
+













+
+
+
+
+
+










+
+
+
+
+
+













+
+
+
+
+
+













+
+
+
+
+
+











-
+


-
+







    namespace import -force ::tcltest::*
}

testConstraint reg 0
if {[testConstraint win]} {
    if {![catch {
	    ::tcltest::loadTestedCommands
	    package require registry
	    set ::regver [package require registry 1.3.3]
	}]} {
	testConstraint reg 1
    }
}

# determine the current locale
testConstraint english [expr {
    [llength [info commands testlocale]]
    && [string match "English*" [testlocale all ""]]
}]


test registry-1.0 {check if we are testing the right dll} {win reg} {
    set ::regver
} {1.3.3}
test registry-1.1 {argument parsing for registry command} {win reg} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.2 {argument parsing for registry command} {win reg} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}}
test registry-1.2a {argument parsing for registry command} {win reg} {
    list [catch {registry -33bit foo} msg] $msg
} {1 {bad mode "-33bit": must be -32bit or -64bit}}

test registry-1.3 {argument parsing for registry command} {win reg} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.3a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit d} msg] $msg
} {1 {wrong # args: should be "registry -32bit delete keyName ?valueName?"}}
test registry-1.3b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit d} msg] $msg
} {1 {wrong # args: should be "registry -64bit delete keyName ?valueName?"}}
test registry-1.4 {argument parsing for registry command} {win reg} {
    list [catch {registry delete} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.5 {argument parsing for registry command} {win reg} {
    list [catch {registry delete foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}

test registry-1.6 {argument parsing for registry command} {win reg} {
    list [catch {registry g} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.6a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit g} msg] $msg
} {1 {wrong # args: should be "registry -32bit get keyName valueName"}}
test registry-1.6b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit g} msg] $msg
} {1 {wrong # args: should be "registry -64bit get keyName valueName"}}
test registry-1.7 {argument parsing for registry command} {win reg} {
    list [catch {registry get} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.8 {argument parsing for registry command} {win reg} {
    list [catch {registry get foo} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.9 {argument parsing for registry command} {win reg} {
    list [catch {registry get foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}

test registry-1.10 {argument parsing for registry command} {win reg} {
    list [catch {registry k} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.10a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit k} msg] $msg
} {1 {wrong # args: should be "registry -32bit keys keyName ?pattern?"}}
test registry-1.10b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit k} msg] $msg
} {1 {wrong # args: should be "registry -64bit keys keyName ?pattern?"}}
test registry-1.11 {argument parsing for registry command} {win reg} {
    list [catch {registry keys} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.12 {argument parsing for registry command} {win reg} {
    list [catch {registry keys foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}

test registry-1.13 {argument parsing for registry command} {win reg} {
    list [catch {registry s} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.13a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit s} msg] $msg
} {1 {wrong # args: should be "registry -32bit set keyName ?valueName data ?type??"}}
test registry-1.13b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit s} msg] $msg
} {1 {wrong # args: should be "registry -64bit set keyName ?valueName data ?type??"}}
test registry-1.14 {argument parsing for registry command} {win reg} {
    list [catch {registry set} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.15 {argument parsing for registry command} {win reg} {
    list [catch {registry set foo bar} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.16 {argument parsing for registry command} {win reg} {
    list [catch {registry set foo bar baz blat gorp} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}

test registry-1.17 {argument parsing for registry command} {win reg} {
    list [catch {registry t} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.17a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit t} msg] $msg
} {1 {wrong # args: should be "registry -32bit type keyName valueName"}}
test registry-1.17b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit t} msg] $msg
} {1 {wrong # args: should be "registry -64bit type keyName valueName"}}
test registry-1.18 {argument parsing for registry command} {win reg} {
    list [catch {registry type} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.19 {argument parsing for registry command} {win reg} {
    list [catch {registry type foo} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.20 {argument parsing for registry command} {win reg} {
    list [catch {registry type foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}

test registry-1.21 {argument parsing for registry command} {win reg} {
    list [catch {registry v} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.21a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit v} msg] $msg
} {1 {wrong # args: should be "registry -32bit values keyName ?pattern?"}}
test registry-1.21b {argument parsing for registry command} {win reg} {
    list [catch {registry -64bit v} msg] $msg
} {1 {wrong # args: should be "registry -64bit values keyName ?pattern?"}}
test registry-1.22 {argument parsing for registry command} {win reg} {
    list [catch {registry values} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.23 {argument parsing for registry command} {win reg} {
    list [catch {registry values foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}

test registry-2.1 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete foo} msg] $msg
} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-2.2 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CURRENT_USER} msg] $msg
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {win reg} {
    list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry keys HKEY_CURRENT_USER TclFoobar
} {}
test registry-2.5 {DeleteKey: subkey below root level} {win reg} {
231
232
233
234
235
236
237
238

239
240
241
242
243
244
245
279
280
281
282
283
284
285

286
287
288
289
290
291
292
293







-
+







    registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u00c7bar
    registry set HKEY_CURRENT_USER\\TclFoobar\\blat
    registry set HKEY_CURRENT_USER\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "baz\u00c7bar blat"
test registry-4.8 {GetKeyNames: Unicode} {win reg nt} {
test registry-4.8 {GetKeyNames: Unicode} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar
    registry set HKEY_CURRENT_USER\\TclFoobar\\blat
    registry set HKEY_CURRENT_USER\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
435
436
437
438
439
440
441
442

443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462



463
464
465

466
467

468

469
470
471



472
473

474


475
476

477
478

479
480
481
482

483


484
485
486
487


488
489
490
491
492
493
494


495
496

497


498
499

500
501

502
503
504
505

506


507
508
509
510


511
512
513
514

515


516
517
518

519
520
521
522
523
524
525







526
527

528


529
530
531
532


533

534
535



536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563





























564
565

566

567
568
569
570
571
572
573


574
575
576

577


578
579

580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597






















598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
















615
616
617
618
619
620
621
622
623
483
484
485
486
487
488
489

490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507



508
509
510
511
512

513
514

515
516
517



518
519
520
521
522
523

524
525
526

527


528
529
530
531
532
533

534
535
536



537
538
539
540
541
542
543


544
545
546
547
548

549
550
551

552


553
554
555
556
557
558

559
560
561



562
563
564
565
566
567
568

569
570
571


572
573






574
575
576
577
578
579
580
581
582
583

584
585
586



587
588
589
590


591
592
593
594



























595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624

625
626
627
628
629
630
631
632


633
634
635
636
637
638

639
640
641

642

643
















644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
















667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691







-
+

















-
-
-
+
+
+


-
+

-
+

+
-
-
-
+
+
+


+
-
+
+

-
+
-
-
+




+
-
+
+

-
-
-
+
+





-
-
+
+


+
-
+
+

-
+
-
-
+




+
-
+
+

-
-
-
+
+




+
-
+
+

-
-
+

-
-
-
-
-
-
+
+
+
+
+
+
+


+
-
+
+

-
-
-
+
+

+
-
-
+
+
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+

+





-
-
+
+



+
-
+
+

-
+
-

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+









} 1
test registry-6.17 {GetValue: Unicode value names} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val\u00c71 foobar multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val\u00c71]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} foobar
test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} {
test registry-6.18 {GetValue: values with Unicode strings} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "foo ba\u30b7r baz"
test registry-6.19 {GetValue: values with Unicode strings} {win reg english} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u00c7r baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} "foo ba r baz"
test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 199] [string repeat x 199] multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 199]]
test registry-6.21 {GetValue: very long value names and values} {win reg} {
    registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
    set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} [string repeat x 199]
} [string repeat x 16383]

test registry-7.1 {GetValueNames: bad key} {win reg english} {
test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
} -body {
    list [catch {registry values HKEY_CURRENT_USER\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-7.2 {GetValueNames} {win reg} {
    registry values HKEY_CURRENT_USER\\TclFoobar
} -returnCodes error -result {unable to open key: The system cannot find the file specified.}
test registry-7.2 {GetValueNames} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz foobar
} -body {
    set result [registry values HKEY_CURRENT_USER\\TclFoobar]
    registry values HKEY_CURRENT_USER\\TclFoobar
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} -result baz
} baz
test registry-7.3 {GetValueNames} {win reg} {
test registry-7.3 {GetValueNames} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1
    registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
    registry set HKEY_CURRENT_USER\\TclFoobar {} foobar3
} -body {
    set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar]]
    lsort [registry values HKEY_CURRENT_USER\\TclFoobar]
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} {
} -result {{} baz blat}
test registry-7.4 {GetValueNames: remote key} -constraints {win reg nonPortable english} -body {
    set hostname [info hostname]
    registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat
    set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar
    set result
} baz
test registry-7.5 {GetValueNames: empty key} {win reg} {
} -result baz
test registry-7.5 {GetValueNames: empty key} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar
} -body {
    set result [registry values HKEY_CURRENT_USER\\TclFoobar]
    registry values HKEY_CURRENT_USER\\TclFoobar
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} -result {}
} {}
test registry-7.6 {GetValueNames: patterns} {win reg} {
test registry-7.6 {GetValueNames: patterns} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1
    registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
    registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3
} -body {
    set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]]
    lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {win reg} {
} -result {baz blat}
test registry-7.7 {GetValueNames: names with spaces} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar baz\ bar foobar1
    registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
    registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3
} -body {
    set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]]
    lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} {{baz bar} blat}
} -result {{baz bar} blat}

test registry-8.1 {OpenSubKey} {win reg nonPortable english} {
    # This test will only succeed if the current user does not have registry
    # access on the specified machine.
    list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {win reg} {
test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \
    -body {
        # This test will only succeed if the current user does not have
        # registry access on the specified machine.
        registry keys {\\mom\HKEY_LOCAL_MACHINE}
    } -returnCodes error -result "unable to open key: Access is denied."
test registry-8.2 {OpenSubKey} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar
} -body {
    set result [registry keys HKEY_CURRENT_USER TclFoobar]
    registry keys HKEY_CURRENT_USER TclFoobar
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} TclFoobar
test registry-8.3 {OpenSubKey} {win reg english} {
} -result {TclFoobar}
test registry-8.3 {OpenSubKey} -constraints {win reg english} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
} -body {
    list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
    registry keys HKEY_CURRENT_USER\\TclFoobar
} -returnCodes error \
    -result "unable to open key: The system cannot find the file specified."

test registry-9.1 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
test registry-9.2 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\foobar} msg] $msg
} {1 {bad key "\foobar": must start with a valid root}}
test registry-9.3 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\\\} msg] $msg
} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.4 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\\\\\} msg] $msg
} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.5 {ParseKeyName: bad keys} {win reg english nt} {
    list [catch {registry values \\\\\\HKEY_CURRENT_USER} msg] $msg
} {1 {unable to open key: The network address is invalid.}}
test registry-9.6 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values \\\\gaspode} msg] $msg
} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.7 {ParseKeyName: bad keys} {win reg} {
    list [catch {registry values foobar} msg] $msg
} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.8 {ParseKeyName: null keys} {win reg} {
    list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-9.9 {ParseKeyName: null keys} {win reg english} {
    list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar\\baz} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-9.1 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\
} -returnCodes error -result "bad key \"\\\": must start with a valid root"
test registry-9.2 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\foobar
} -returnCodes error -result {bad key "\foobar": must start with a valid root}
test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\\\
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\\\\\
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body {
    registry values \\\\\\HKEY_CLASSES_ROOT
} -returnCodes error -result {unable to open key: The network address is invalid.}
test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values \\\\gaspode
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.7 {ParseKeyName: bad keys} -constraints {win reg} -body {
    registry values foobar
} -returnCodes error -result {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
test registry-9.8 {ParseKeyName: null keys} -constraints {win reg} -body {
    registry delete HKEY_CLASSES_ROOT\\
} -returnCodes error -result {bad key: cannot delete root keys}
test registry-9.9 {ParseKeyName: null keys} \
    -constraints {win reg english} \
    -body {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} \
    -returnCodes error \
    -result {unable to open key: The system cannot find the file specified.}

test registry-10.1 {RecursiveDeleteKey} {win reg} {
test registry-10.1 {RecursiveDeleteKey} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
} -body {
    registry set HKEY_CURRENT_USER\\TclFoobar\\test1
    registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result [registry keys HKEY_CURRENT_USER TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {win reg} {
} -result {}
test registry-10.2 {RecursiveDeleteKey} -constraints {win reg} -setup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\test1
    registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
} -body {
    set result [registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4]
    registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4
} -cleanup {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    set result
} -result {}
} {}

test registry-11.1 {SetValue: recursive creation} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
    set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
} foobar
test registry-11.2 {SetValue: modification} {win reg} {
    registry delete HKEY_CURRENT_USER\\TclFoobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
    registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob
    set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
} frob
test registry-11.3 {SetValue: failure} {win reg nonPortable english} {
    # This test will only succeed if the current user does not have registry
    # access on the specified machine.
    list [catch {registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-11.1 {SetValue: recursive creation} \
    -constraints {win reg} -setup {
        registry delete HKEY_CURRENT_USER\\TclFoobar
    } -body {
        registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
        set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
    } -result {foobar}
test registry-11.2 {SetValue: modification} -constraints {win reg} \
    -setup {
        registry delete HKEY_CURRENT_USER\\TclFoobar
    } -body {
        registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
        registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob
        set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
    } -result {frob}
test registry-11.3 {SetValue: failure} \
    -constraints {win reg nonPortable english} \
    -body {
        # This test will only succeed if the current user does not have
        # registry access on the specified machine.
        registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar
    } -returnCodes error -result {unable to open key: Access is denied.}

test registry-12.1 {BroadcastValue} {win reg} {
    list [catch {registry broadcast} msg] $msg
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
test registry-12.2 {BroadcastValue} {win reg} {
    list [catch {registry broadcast "" -time} msg] $msg
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
test registry-12.3 {BroadcastValue} {win reg} {
    list [catch {registry broadcast "" - 500} msg] $msg
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
test registry-12.4 {BroadcastValue} {win reg} {
    list [catch {registry broadcast {Environment}} msg] $msg
} {0 {1 0}}
test registry-12.5 {BroadcastValue} {win reg} {
    list [catch {registry b {}} msg] $msg
} {0 {1 0}}

test registry-12.1 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast "" -time
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.3 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast "" - 500
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.4 {BroadcastValue} -constraints {win reg} -body {
    registry broadcast {Environment}
} -result {1 0}
test registry-12.5 {BroadcastValue} -constraints {win reg} -body {
    registry b {}
} -result {1 0}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# tcl-indent-level: 4
# fill-column: 78
# End:
Changes to win/Makefile.in.
491
492
493
494
495
496
497
498

499
500
501
502
503
504
505
491
492
493
494
495
496
497

498
499
500
501
502
503
504
505







-
+








tclAppInit.${OBJEXT} : tclAppInit.c
	$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)

# The following objects should be built using the stub interfaces

tclWinReg.${OBJEXT} : tclWinReg.c
	$(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)
	$(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)

tclWinDde.${OBJEXT} : tclWinDde.c
	$(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME)

# TIP #59, embedding of configuration information into the binary library.
#
# Part of Tcl's configuration information are the paths where it was installed
706
707
708
709
710
711
712
713

714
715
716
717
718
719

720
721
722
723
724
725
726
706
707
708
709
710
711
712

713
714
715
716
717
718

719
720
721
722
723
724
725
726







-
+





-
+







# tcltest, i.e.:
#	% make test TESTFLAGS="-verbose bps -file fileName.test"

test: binaries $(TCLTEST)
	TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
	./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
	-load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
	package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
	package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)

# Useful target to launch a built tcltest with the proper path,...
runtest: binaries $(TCLTEST)
	@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
	./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
	package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)
	package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT)

# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
shell: binaries
	@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
	./$(TCLSH) $(SCRIPT)

Changes to win/configure.in.
18
19
20
21
22
23
24
25

26
27

28
29
30
31
32
33
34
18
19
20
21
22
23
24

25
26

27
28
29
30
31
32
33
34







-
+

-
+







VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION

TCL_REG_VERSION=1.2
TCL_REG_VERSION=1.3
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=2
TCL_REG_MINOR_VERSION=3
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
Changes to win/makefile.bc.
126
127
128
129
130
131
132
133
134


135
136
137
138
139
140
141
126
127
128
129
130
131
132


133
134
135
136
137
138
139
140
141







-
-
+
+







STUBPREFIX	= $(NAMEPREFIX)stub
DOTVERSION	= 8.5
VERSION		= 85

DDEVERSION = 13
DDEDOTVERSION = 1.3

REGVERSION = 12
REGDOTVERSION = 1.2
REGVERSION = 13
REGDOTVERSION = 1.3

BINROOT		= ..
!IF "$(NODEBUG)" == "1"
TMPDIRNAME	= Release
DBGX		=
SYMDEFINES	= -DNDEBUG
!ELSE
Changes to win/makefile.vc.
181
182
183
184
185
186
187
188

189
190
191
192
193
194
195
181
182
183
184
185
186
187

188
189
190
191
192
193
194
195







-
+







STUBPREFIX      = $(PROJECT)stub
DOTVERSION      = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION         = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)

DDEDOTVERSION = 1.3
DDEVERSION = $(DDEDOTVERSION:.=)

REGDOTVERSION = 1.2
REGDOTVERSION = 1.3
REGVERSION = $(REGDOTVERSION:.=)

BINROOT		= .
ROOT		= ..

TCLIMPLIB	= $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
TCLLIBNAME	= $(PROJECT)$(VERSION)$(SUFX).$(EXT)
535
536
537
538
539
540
541
542

543
544
545
546
547
548

549
550
551
552
553
554
555
535
536
537
538
539
540
541

542
543
544
545
546
547

548
549
550
551
552
553
554
555







-
+





-
+








test: test-core
test-core: setup $(TCLTEST) dlls $(CAT32)
	set TCL_LIBRARY=$(ROOT:\=/)/library
!if "$(OS)" == "Windows_NT"  || "$(MSVCDIR)" == "IDE"
	$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
		package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde]
		package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry]
		package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry]
<<
!else
	@echo Please wait while the tests are collected...
	$(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log
		package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde]
		package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry]
		package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry]
<<
	type tests.log | more
!endif

runtest: setup $(TCLTEST) dlls $(CAT32)
	set TCL_LIBRARY=$(ROOT:\=/)/library
	$(DEBUGGER) $(TCLTEST) $(SCRIPT)
881
882
883
884
885
886
887
888

889
890

891
892
893
894
895
896
897
881
882
883
884
885
886
887

888
889

890
891
892
893
894
895
896
897







-
+

-
+







	    -Fo$@ $?

### The following objects should be built using the stub interfaces
### *ALL* extensions need to built with -DTCL_THREADS=1

$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c
!if $(STATIC_BUILD)
	$(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $?
	$(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $?
!else
	$(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $?
	$(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $?
!endif


$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c
!if $(STATIC_BUILD)
	$(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $?
!else
Changes to win/rules.vc.
586
587
588
589
590
591
592
593

594
595
596
597
598
599
600
601
602
603
604
605
606

607
608
609
610
611
612
613
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600
601
602
603
604
605

606
607
608
609
610
611
612
613







-
+












-
+







TCLSH		= "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
!if !exist($(TCLSH)) && $(TCL_THREADS)
TCLSH           = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe"
!endif
TCLSTUBLIB	= "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib"
TCLIMPLIB	= "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY	= $(_TCLDIR)\lib
TCLREGLIB	= "$(_TCLDIR)\lib\tclreg12$(SUFX:t=).lib"
TCLREGLIB	= "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib"
TCLDDELIB	= "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib"
COFFBASE	= \must\have\tcl\sources\to\build\this\target
TCLTOOLSDIR	= \must\have\tcl\sources\to\build\this\target
TCL_INCLUDES    = -I"$(_TCLDIR)\include"
!else
TCLSH		= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe"
!if !exist($(TCLSH)) && $(TCL_THREADS)
TCLSH		= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe"
!endif
TCLSTUBLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
TCLIMPLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY	= $(_TCLDIR)\library
TCLREGLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib"
TCLREGLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib"
TCLDDELIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib"
COFFBASE	= "$(_TCLDIR)\win\coffbase.txt"
TCLTOOLSDIR	= $(_TCLDIR)\tools
TCL_INCLUDES	= -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif

!endif
Changes to win/tclWinReg.c.
8
9
10
11
12
13
14




15
16
17
18
19
20
21
22
23

24
25
26
27
28
29






30
31
32
33
34
35
36

37
38
39
40
41
42
43
44


45
46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
66
67
68
69

70
71
72
73
74
75
76
77

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

166
167
168


169
170

171
172

173
174

175
176

177
178

179
180
181
182
183
184
185
186
187
188

189
190
191

192
193
194

195
196
197


198
199
200
201
202
203
204
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25

26


27
28


29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47


48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70
71
72
73

74
75
76
77
78
79
80
81

82
83
84
85
86
87











































































88
89
90
91
92
93
94

95
96
97

98
99
100

101
102

103
104

105
106

107
108

109
110
111
112
113
114
115
116
117
118

119
120
121

122
123
124

125
126


127
128
129
130
131
132
133
134
135







+
+
+
+

-






-
+
-
-


-
-
+
+
+
+
+
+






-
+






-
-
+
+













-
+










-
+







-
+





-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-







-
+


-
+
+

-
+

-
+

-
+

-
+

-
+









-
+


-
+


-
+

-
-
+
+







 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include "tclInt.h"
#include "tclPort.h"
#ifdef _MSC_VER
#   pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
 * Ensure that we can say which registry is being accessed.
 * Registry_Init declaration is in the source file itself, which is only
 * accessed when we are building a library.
 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
#ifndef KEY_WOW64_64KEY
#   define KEY_WOW64_64KEY	(0x0100)
#endif
#ifndef KEY_WOW64_32KEY
#   define KEY_WOW64_32KEY	(0x0200)
#endif

/*
 * The maximum length of a sub-key name.
 */

#ifndef MAX_KEY_LENGTH
#define MAX_KEY_LENGTH		256
#   define MAX_KEY_LENGTH	256
#endif

/*
 * The following macros convert between different endian ints.
 */

#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
#define SWAPWORD(x)	MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x)	MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))

/*
 * The following flag is used in OpenKeys to indicate that the specified key
 * should be created if it doesn't currently exist.
 */

#define REG_CREATE 1

/*
 * The following tables contain the mapping from registry root names to the
 * system predefined keys.
 */

static CONST char *rootKeyNames[] = {
static const char *const rootKeyNames[] = {
    "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
    "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
    "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
};

static const HKEY rootKeys[] = {
    HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
    HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};

static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";
static const char REGISTRY_ASSOC_KEY[] = "registry::command";

/*
 * The following table maps from registry types to strings. Note that the
 * indices for this array are the same as the constants for the known registry
 * types so we don't need a separate table to hold the mapping.
 */

static CONST char *typeNames[] = {
static const char *const typeNames[] = {
    "none", "sz", "expand_sz", "binary", "dword",
    "dword_big_endian", "link", "multi_sz", "resource_list", NULL
};

static DWORD lastType = REG_RESOURCE_LIST;

/*
 * The following structures allow us to select between the Unicode and ASCII
 * interfaces at run time based on whether Unicode APIs are available. The
 * Unicode APIs are preferable because they will handle characters outside of
 * the current code page.
 */

typedef struct RegWinProcs {
    int useWide;

    LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
    LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
    LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
    LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *);
    LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *);
    LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
	    HKEY *);
    LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
	    BYTE *, DWORD *);
    LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
	    CONST BYTE*, DWORD);
} RegWinProcs;

static RegWinProcs *regWinProcs;

static RegWinProcs asciiProcs = {
    0,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
	    HKEY *)) RegOpenKeyExA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
	    BYTE *, DWORD *)) RegQueryValueExA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
	    CONST BYTE*, DWORD)) RegSetValueExA,
};

static RegWinProcs unicodeProcs = {
    1,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
	    HKEY *)) RegOpenKeyExW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
	    BYTE *, DWORD *)) RegQueryValueExW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
	    CONST BYTE*, DWORD)) RegSetValueExW,
};


/*
 * Declarations for functions defined in this file.
 */

static void		AppendSystemError(Tcl_Interp *interp, DWORD error);
static int		BroadcastValue(Tcl_Interp *interp, int objc,
			    Tcl_Obj * CONST objv[]);
			    Tcl_Obj *const objv[]);
static DWORD		ConvertDWORD(DWORD type, DWORD value);
static void		DeleteCmd(ClientData clientData);
static int		DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
static int		DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    REGSAM mode);
static int		DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj);
			    Tcl_Obj *valueNameObj, REGSAM mode);
static int		GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *patternObj);
			    Tcl_Obj *patternObj, REGSAM mode);
static int		GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj);
			    Tcl_Obj *valueNameObj, REGSAM mode);
static int		GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj);
			    Tcl_Obj *valueNameObj, REGSAM mode);
static int		GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *patternObj);
			    Tcl_Obj *patternObj, REGSAM mode);
static int		OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    REGSAM mode, int flags, HKEY *keyPtr);
static DWORD		OpenSubKey(char *hostName, HKEY rootKey,
			    char *keyName, REGSAM mode, int flags,
			    HKEY *keyPtr);
static int		ParseKeyName(Tcl_Interp *interp, char *name,
			    char **hostNamePtr, HKEY *rootKeyPtr,
			    char **keyNamePtr);
static DWORD		RecursiveDeleteKey(HKEY hStartKey,
			    CONST TCHAR * pKeyName);
			    const TCHAR * pKeyName, REGSAM mode);
static int		RegistryObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj * CONST objv[]);
			    Tcl_Obj *const objv[]);
static int		SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
			    Tcl_Obj *typeObj);
			    Tcl_Obj *typeObj, REGSAM mode);

EXTERN int		Registry_Init(Tcl_Interp *interp);
EXTERN int		Registry_Unload(Tcl_Interp *interp, int flags);
DLLEXPORT int		Registry_Init(Tcl_Interp *interp);
DLLEXPORT int		Registry_Unload(Tcl_Interp *interp, int flags);

/*
 *----------------------------------------------------------------------
 *
 * Registry_Init --
 *
 *	This function initializes the registry command.
214
215
216
217
218
219
220
221

222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239



240
241
242
243
244
245
246
145
146
147
148
149
150
151

152
153
154
155











156



157
158
159
160
161
162
163
164
165
166







-
+



-
-
-
-
-
-
-
-
-
-
-

-
-
-
+
+
+








int
Registry_Init(
    Tcl_Interp *interp)
{
    Tcl_Command cmd;

    if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
    if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
	return TCL_ERROR;
    }

    /*
     * Determine if the unicode interfaces are available and select the
     * appropriate registry function table.
     */

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
	regWinProcs = &unicodeProcs;
    } else {
	regWinProcs = &asciiProcs;
    }

    cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
	(ClientData)interp, DeleteCmd);
    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd);
    return Tcl_PkgProvide(interp, "registry", "1.2.2");
	    interp, DeleteCmd);
    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
    return Tcl_PkgProvide(interp, "registry", "1.3.3");
}

/*
 *----------------------------------------------------------------------
 *
 * Registry_Unload --
 *
272
273
274
275
276
277
278
279

280
281
282
283
284
285
286
192
193
194
195
196
197
198

199
200
201
202
203
204
205
206







-
+







    objv[2] = Tcl_NewStringObj("registry", -1);
    Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);

    /*
     * Delete the originally registered command.
     */

    cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
    cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
    if (cmd != NULL) {
	Tcl_DeleteCommandFromToken(interp, cmd);
    }

    return TCL_OK;
}

302
303
304
305
306
307
308

309

310
311
312
313
314
315
316
222
223
224
225
226
227
228
229

230
231
232
233
234
235
236
237







+
-
+







 */

static void
DeleteCmd(
    ClientData clientData)
{
    Tcl_Interp *interp = clientData;

    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL);
    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * RegistryObjCmd --
 *
326
327
328
329
330
331
332
333

334

335
336



337
338

339
340
341
342
343



344
345

346

347
348
349

350
351



















352
353
354

355
356

357







358
359
360
361
362
363




364
365
366
367
368
369


370
371
372
373
374
375
376
377




378
379
380
381
382

383
384
385
386
387
388

389

390
391
392
393
394
395
396






397
398
399
400
401
402


403
404
405
406
407
408
409
410




411
412
413
414
415

416
417
418
419
420
421
422
247
248
249
250
251
252
253

254
255
256


257
258
259
260

261
262
263
264
265
266
267
268
269
270
271
272

273
274
275
276
277


278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

304
305
306
307
308
309
310
311
312




313
314
315
316
317
318
319
320


321
322
323
324
325
326




327
328
329
330
331
332
333
334

335
336
337
338
339
340
341
342

343
344
345
346
347



348
349
350
351
352
353
354
355
356
357


358
359
360
361
362
363




364
365
366
367
368
369
370
371

372
373
374
375
376
377
378
379







-
+

+
-
-
+
+
+

-
+





+
+
+


+
-
+



+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



+


+
-
+
+
+
+
+
+
+


-
-
-
-
+
+
+
+




-
-
+
+




-
-
-
-
+
+
+
+




-
+






+
-
+




-
-
-
+
+
+
+
+
+




-
-
+
+




-
-
-
-
+
+
+
+




-
+







 */

static int
RegistryObjCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj * CONST objv[])	/* Argument values. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    int n = 1;
    int index;
    char *errString = NULL;
    int index, argc;
    REGSAM mode = 0;
    const char *errString = NULL;

    static CONST char *subcommands[] = {
    static const char *const subcommands[] = {
	"broadcast", "delete", "get", "keys", "set", "type", "values", NULL
    };
    enum SubCmdIdx {
	BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
    };
    static const char *const modes[] = {
	"-32bit", "-64bit", NULL
    };

    if (objc < 2) {
    wrongArgs:
	Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
	Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetString(objv[n])[0] == '-') {
    if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
	    != TCL_OK) {
	if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (index) {
	case 0:			/* -32bit */
	    mode |= KEY_WOW64_32KEY;
	    break;
	case 1:			/* -64bit */
	    mode |= KEY_WOW64_64KEY;
	    break;
	}
	if (objc < 3) {
	    goto wrongArgs;
	}
    }

    if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    argc = (objc - n);
    switch (index) {
    case BroadcastIdx:		/* broadcast */
	if (argc == 1 || argc == 3) {
	return BroadcastValue(interp, objc, objv);
	    int res = BroadcastValue(interp, argc, objv + n);

	    if (res != TCL_BREAK) {
		return res;
	    }
	}
	errString = "keyName ?-timeout milliseconds?";
	break;
    case DeleteIdx:		/* delete */
	if (objc == 3) {
	    return DeleteKey(interp, objv[2]);
	} else if (objc == 4) {
	    return DeleteValue(interp, objv[2], objv[3]);
	if (argc == 1) {
	    return DeleteKey(interp, objv[n], mode);
	} else if (argc == 2) {
	    return DeleteValue(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName ?valueName?";
	break;
    case GetIdx:		/* get */
	if (objc == 4) {
	    return GetValue(interp, objv[2], objv[3]);
	if (argc == 2) {
	    return GetValue(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName valueName";
	break;
    case KeysIdx:		/* keys */
	if (objc == 3) {
	    return GetKeyNames(interp, objv[2], NULL);
	} else if (objc == 4) {
	    return GetKeyNames(interp, objv[2], objv[3]);
	if (argc == 1) {
	    return GetKeyNames(interp, objv[n], NULL, mode);
	} else if (argc == 2) {
	    return GetKeyNames(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName ?pattern?";
	break;
    case SetIdx:		/* set */
	if (objc == 3) {
	if (argc == 1) {
	    HKEY key;

	    /*
	     * Create the key and then close it immediately.
	     */

	    mode |= KEY_ALL_ACCESS;
	    if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
	    if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) {
		return TCL_ERROR;
	    }
	    RegCloseKey(key);
	    return TCL_OK;
	} else if (objc == 5 || objc == 6) {
	    Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
	    return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
	} else if (argc == 3) {
	    return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL,
		    mode);
	} else if (argc == 4) {
	    return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3],
		    mode);
	}
	errString = "keyName ?valueName data ?type??";
	break;
    case TypeIdx:		/* type */
	if (objc == 4) {
	    return GetType(interp, objv[2], objv[3]);
	if (argc == 2) {
	    return GetType(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName valueName";
	break;
    case ValuesIdx:		/* values */
	if (objc == 3) {
	    return GetValueNames(interp, objv[2], NULL);
	} else if (objc == 4) {
	    return GetValueNames(interp, objv[2], objv[3]);
	if (argc == 1) {
	    return GetValueNames(interp, objv[n], NULL, mode);
	} else if (argc == 2) {
	    return GetValueNames(interp, objv[n], objv[n+1], mode);
	}
	errString = "keyName ?pattern?";
	break;
    }
    Tcl_WrongNumArgs(interp, 2, objv, errString);
    Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteKey --
431
432
433
434
435
436
437
438


439
440
441

442
443
444
445

446
447
448
449
450
451
452


453
454
455
456
457

458
459
460
461
462
463
464




465
466
467
468
469
470
471
472
473
474
475

476

477
478
479

480
481
482
483
484


485
486
487
488
489
490
491
492
493
494

495
496
497
498
499
500
501
502
503
504
505
506
507

508
509
510
511
512
513
514
388
389
390
391
392
393
394

395
396
397
398

399
400
401

402
403
404
405
406
407
408


409
410
411
412
413
414

415
416
417
418
419



420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435

436

437

438
439
440
441


442
443
444
445
446
447
448
449
450
451
452

453
454
455
456
457
458
459
460
461
462
463
464
465

466
467
468
469
470
471
472
473







-
+
+


-
+


-

+





-
-
+
+




-
+




-
-
-
+
+
+
+











+
-
+
-

-
+



-
-
+
+









-
+












-
+







 *
 *----------------------------------------------------------------------
 */

static int
DeleteKey(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj)	/* Name of key to delete. */
    Tcl_Obj *keyNameObj,	/* Name of key to delete. */
    REGSAM mode)		/* Mode flags to pass. */
{
    char *tail, *buffer, *hostName, *keyName;
    CONST char *nativeTail;
    const TCHAR *nativeTail;
    HKEY rootKey, subkey;
    DWORD result;
    int length;
    Tcl_DString buf;
    REGSAM saveMode = mode;

    /*
     * Find the parent of the key being deleted and open it.
     */

    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc((unsigned int) length + 1);
    keyName = Tcl_GetString(keyNameObj);
    buffer = Tcl_Alloc(keyNameObj->length + 1);
    strcpy(buffer, keyName);

    if (ParseKeyName(interp, buffer, &hostName, &rootKey,
	    &keyName) != TCL_OK) {
	ckfree(buffer);
	Tcl_Free(buffer);
	return TCL_ERROR;
    }

    if (*keyName == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad key: cannot delete root keys", -1));
	ckfree(buffer);
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("bad key: cannot delete root keys", -1));
	Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL);
	Tcl_Free(buffer);
	return TCL_ERROR;
    }

    tail = strrchr(keyName, '\\');
    if (tail) {
	*tail++ = '\0';
    } else {
	tail = keyName;
	keyName = NULL;
    }

    mode |= KEY_ENUMERATE_SUB_KEYS | DELETE;
    result = OpenSubKey(hostName, rootKey, keyName,
    result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey);
	    KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
    if (result != ERROR_SUCCESS) {
	ckfree(buffer);
	Tcl_Free(buffer);
	if (result == ERROR_FILE_NOT_FOUND) {
	    return TCL_OK;
	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"unable to delete key: ", -1));
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("unable to delete key: ", -1));
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }

    /*
     * Now we recursively delete the key and everything below it.
     */

    nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf);
    result = RecursiveDeleteKey(subkey, nativeTail);
    result = RecursiveDeleteKey(subkey, nativeTail, saveMode);
    Tcl_DStringFree(&buf);

    if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("unable to delete key: ", -1));
	AppendSystemError(interp, result);
	result = TCL_ERROR;
    } else {
	result = TCL_OK;
    }

    RegCloseKey(subkey);
    ckfree(buffer);
    Tcl_Free(buffer);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteValue --
524
525
526
527
528
529
530
531


532
533
534
535

536
537
538
539
540
541
542

543

544
545
546
547
548


549
550

551
552

553
554


555
556
557
558
559
560
561
562
483
484
485
486
487
488
489

490
491
492
493
494

495
496
497
498
499
500
501
502
503

504

505
506
507

508
509
510

511
512
513
514


515
516

517
518
519
520
521
522
523







-
+
+



-
+







+
-
+
-



-
+
+

-
+


+
-
-
+
+
-







 *----------------------------------------------------------------------
 */

static int
DeleteValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj)	/* Name of value to delete. */
    Tcl_Obj *valueNameObj,	/* Name of value to delete. */
    REGSAM mode)		/* Mode flags to pass. */
{
    HKEY key;
    char *valueName;
    int length;
    size_t length;
    DWORD result;
    Tcl_DString ds;

    /*
     * Attempt to open the key for deletion.
     */

    mode |= KEY_SET_VALUE;
    if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
    if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
	    != TCL_OK) {
	return TCL_ERROR;
    }

    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    valueName = Tcl_GetString(valueNameObj);
    length = valueNameObj->length;
    Tcl_WinUtfToTChar(valueName, length, &ds);
    result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
    result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
    Tcl_DStringFree(&ds);
    if (result != ERROR_SUCCESS) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	Tcl_AppendResult(interp, "unable to delete value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		"unable to delete value \"%s\" from key \"%s\": ",
		Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	result = TCL_ERROR;
    } else {
	result = TCL_OK;
    }
    RegCloseKey(key);
    return result;
581
582
583
584
585
586
587
588


589
590

591
592


593
594
595
596
597
598
599
600
601
602
603
604
605

606


607
608
609
610


611
612
613

614


615
616
617
618
619
620


621
622
623
624
625

626
627
628


629
630
631
632
633
634
635

636
637
638
639
640
641
642
643
644
645
646
542
543
544
545
546
547
548

549
550
551

552
553

554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569

570
571
572



573
574
575
576
577
578

579
580
581
582
583
584


585
586
587
588
589
590

591



592
593
594
595
596
597
598


599




600
601
602
603
604
605
606







-
+
+

-
+

-
+
+













+
-
+
+

-
-
-
+
+



+
-
+
+




-
-
+
+




-
+
-
-
-
+
+





-
-
+
-
-
-
-







 *----------------------------------------------------------------------
 */

static int
GetKeyNames(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Key to enumerate. */
    Tcl_Obj *patternObj)	/* Optional match pattern. */
    Tcl_Obj *patternObj,	/* Optional match pattern. */
    REGSAM mode)		/* Mode flags to pass. */
{
    char *pattern;		/* Pattern being matched against subkeys */
    const char *pattern;	/* Pattern being matched against subkeys */
    HKEY key;			/* Handle to the key being examined */
    TCHAR buffer[MAX_KEY_LENGTH*2];		/* Buffer to hold the subkey name */
    TCHAR buffer[MAX_KEY_LENGTH];
				/* Buffer to hold the subkey name */
    DWORD bufSize;		/* Size of the buffer */
    DWORD index;		/* Position of the current subkey */
    char *name;			/* Subkey name */
    Tcl_Obj *resultPtr;		/* List of subkeys being accumulated */
    int result = TCL_OK;	/* Return value from this command */
    Tcl_DString ds;		/* Buffer to translate subkey name to UTF-8 */

    if (patternObj) {
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
    /* Attempt to open the key for enumeration. */
     * Attempt to open the key for enumeration.
     */

    if (OpenKey(interp, keyNameObj,
		KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS,
		0, &key) != TCL_OK) {
    mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS;
    if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
    /* Enumerate the subkeys */
     * Enumerate the subkeys.
     */

    resultPtr = Tcl_NewObj();
    for (index = 0;; ++index) {
	bufSize = MAX_KEY_LENGTH;
	result = (*regWinProcs->regEnumKeyExProc)
	    (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL);
	result = RegEnumKeyEx(key, index, buffer, &bufSize,
		NULL, NULL, NULL, NULL);
	if (result != ERROR_SUCCESS) {
	    if (result == ERROR_NO_MORE_ITEMS) {
		result = TCL_OK;
	    } else {
		Tcl_SetObjResult(interp, Tcl_NewObj());
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		Tcl_AppendResult(interp,
			"unable to enumerate subkeys of \"",
			Tcl_GetString(keyNameObj), "\": ", NULL);
			"unable to enumerate subkeys of \"%s\": ",
			Tcl_GetString(keyNameObj)));
		AppendSystemError(interp, result);
		result = TCL_ERROR;
	    }
	    break;
	}
	if (regWinProcs->useWide) {
	    Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds);
	name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds);
	} else {
	    Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds);
	}
	name = Tcl_DStringValue(&ds);
	if (pattern && !Tcl_StringMatch(name, pattern)) {
	    Tcl_DStringFree(&ds);
	    continue;
	}
	result = Tcl_ListObjAppendElement(interp, resultPtr,
		Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
	Tcl_DStringFree(&ds);
675
676
677
678
679
680
681
682


683
684
685

686
687
688
689
690



691
692
693
694
695

696

697
698
699
700
701
702
703
704
705


706
707

708
709
710
711
712

713
714


715
716
717
718
719
720
721
722
635
636
637
638
639
640
641

642
643
644
645

646

647



648
649
650
651
652
653
654
655
656

657

658
659
660
661
662
663
664

665
666
667

668
669
670
671
672
673
674


675
676

677
678
679
680
681
682
683







-
+
+


-
+
-

-
-
-
+
+
+





+
-
+
-







-
+
+

-
+





+
-
-
+
+
-







 *----------------------------------------------------------------------
 */

static int
GetType(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj)	/* Name of value to get. */
    Tcl_Obj *valueNameObj,	/* Name of value to get. */
    REGSAM mode)		/* Mode flags to pass. */
{
    HKEY key;
    DWORD result;
    DWORD result, type;
    DWORD type;
    Tcl_DString ds;
    char *valueName;
    CONST char *nativeValue;
    int length;
    const char *valueName;
    const TCHAR *nativeValue;
    size_t length;

    /*
     * Attempt to open the key for reading.
     */

    mode |= KEY_QUERY_VALUE;
    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
    if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
	    != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Get the type of the value.
     */

    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    valueName = Tcl_GetString(valueNameObj);
    length = valueNameObj->length;
    nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
    result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
    result = RegQueryValueEx(key, nativeValue, NULL, &type,
	    NULL, NULL);
    Tcl_DStringFree(&ds);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	Tcl_AppendResult(interp, "unable to get type of value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		"unable to get type of value \"%s\" from key \"%s\": ",
		Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }

    /*
     * Set the type into the result. Watch out for unknown types. If we don't
     * know about the type, just use the numeric value.
747
748
749
750
751
752
753
754


755
756
757
758


759
760
761

762
763
764
765
766

767

768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783

784
785


786
787
788

789
790
791
792
793
794
795
796
797
798
799



800
801
802
803
804

805
806


807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822

823
824
825
826
827
828
829
830
831
832
833
834
835



836
837
838
839
840
841
842
843




844
845
846
847
848
849
850
851
852
853
708
709
710
711
712
713
714

715
716
717
718


719
720
721
722

723
724
725
726
727
728
729

730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745

746
747

748
749
750
751

752
753
754
755
756
757
758
759
760



761
762
763
764
765
766
767
768
769


770
771

772
773
774
775
776
777
778
779
780
781
782
783
784
785

786
787
788
789
790
791
792
793
794
795
796
797


798
799
800
801
802
803
804




805
806
807
808



809
810
811
812
813
814
815







-
+
+


-
-
+
+


-
+





+
-
+















-
+

-
+
+


-
+








-
-
-
+
+
+





+
-
-
+
+
-














-
+











-
-
+
+
+




-
-
-
-
+
+
+
+
-
-
-







 *----------------------------------------------------------------------
 */

static int
GetValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj)	/* Name of value to get. */
    Tcl_Obj *valueNameObj,	/* Name of value to get. */
    REGSAM mode)		/* Mode flags to pass. */
{
    HKEY key;
    char *valueName;
    CONST char *nativeValue;
    const char *valueName;
    const TCHAR *nativeValue;
    DWORD result, length, type;
    Tcl_DString data, buf;
    int nameLen;
    size_t nameLen;

    /*
     * Attempt to open the key for reading.
     */

    mode |= KEY_QUERY_VALUE;
    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) {
    if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Initialize a Dstring to maximum statically allocated size we could get
     * one more byte by avoiding Tcl_DStringSetLength() and just setting
     * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
     * implementation of Dstrings changes.
     *
     * This allows short values to be read from the registy in one call.
     * Longer values need a second call with an expanded DString.
     */

    Tcl_DStringInit(&data);
    Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
    length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1;
    length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1;

    valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
    valueName = Tcl_GetString(valueNameObj);
    nameLen = valueNameObj->length;
    nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);

    result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
    result = RegQueryValueEx(key, nativeValue, NULL, &type,
	    (BYTE *) Tcl_DStringValue(&data), &length);
    while (result == ERROR_MORE_DATA) {
	/*
	 * The Windows docs say that in this error case, we just need to
	 * expand our buffer and request more data. Required for
	 * HKEY_PERFORMANCE_DATA
	 */

	length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2);
	Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1));
	result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
	length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR));
	Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR));
	result = RegQueryValueEx(key, nativeValue,
		NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
    }
    Tcl_DStringFree(&buf);
    RegCloseKey(key);
    if (result != ERROR_SUCCESS) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	Tcl_AppendResult(interp, "unable to get value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		"unable to get value \"%s\" from key \"%s\": ",
		Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	Tcl_DStringFree(&data);
	return TCL_ERROR;
    }

    /*
     * If the data is a 32-bit quantity, store it as an integer object. If it
     * is a multi-string, store it as a list of strings. For null-terminated
     * strings, append up the to first null. Otherwise, store it as a binary
     * string.
     */

    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
		*((DWORD*) Tcl_DStringValue(&data)))));
		*((DWORD *) Tcl_DStringValue(&data)))));
    } else if (type == REG_MULTI_SZ) {
	char *p = Tcl_DStringValue(&data);
	char *end = Tcl_DStringValue(&data) + length;
	Tcl_Obj *resultPtr = Tcl_NewObj();

	/*
	 * Multistrings are stored as an array of null-terminated strings,
	 * terminated by two null characters. Also do a bounds check in case
	 * we get bogus data.
	 */

	while (p < end 	&& ((regWinProcs->useWide)
		? *((Tcl_UniChar *)p) : *p) != 0) {
	while ((p < end) && *((WCHAR *) p) != 0) {
	    WCHAR *wp;

	    Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
	    Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(Tcl_DStringValue(&buf),
			    Tcl_DStringLength(&buf)));
	    if (regWinProcs->useWide) {
		Tcl_UniChar* up = (Tcl_UniChar*) p;
		while (*up++ != 0) {}
		p = (char*) up;
	    wp = (WCHAR *) p;

	    while (*wp++ != 0) {/* empty body */}
	    p = (char *) wp;
	    } else {
		while (*p++ != '\0') {}
	    }
	    Tcl_DStringFree(&buf);
	}
	Tcl_SetObjResult(interp, resultPtr);
    } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
	Tcl_DStringResult(interp, &buf);
    } else {
881
882
883
884
885
886
887
888


889
890
891
892
893
894

895
896
897
898
899

900

901
902
903
904
905
906
907

908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927


928
929
930

931
932
933
934
935
936
937
938
843
844
845
846
847
848
849

850
851
852
853
854
855
856

857
858
859
860
861
862
863

864

865
866
867
868
869

870

871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886



887
888



889

890
891
892
893
894
895
896







-
+
+





-
+





+
-
+
-





-
+
-
















-
-
-
+
+
-
-
-
+
-







 *----------------------------------------------------------------------
 */

static int
GetValueNames(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Key to enumerate. */
    Tcl_Obj *patternObj)	/* Optional match pattern. */
    Tcl_Obj *patternObj,	/* Optional match pattern. */
    REGSAM mode)		/* Mode flags to pass. */
{
    HKEY key;
    Tcl_Obj *resultPtr;
    DWORD index, size, result;
    Tcl_DString buffer, ds;
    char *pattern, *name;
    const char *pattern, *name;

    /*
     * Attempt to open the key for enumeration.
     */

    mode |= KEY_QUERY_VALUE;
    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
    if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
	    != TCL_OK) {
	return TCL_ERROR;
    }

    resultPtr = Tcl_NewObj();
    Tcl_DStringInit(&buffer);
    Tcl_DStringSetLength(&buffer,
    Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR)));
	    (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH));
    index = 0;
    result = TCL_OK;

    if (patternObj) {
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
     * Enumerate the values under the given subkey until we get an error,
     * indicating the end of the list. Note that we need to reset size after
     * each iteration because RegEnumValue smashes the old value.
     */

    size = MAX_KEY_LENGTH;
    while ((*regWinProcs->regEnumValueProc)(key, index,
	    Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
	    == ERROR_SUCCESS) {
    while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer),
	    &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {

	if (regWinProcs->useWide) {
	    size *= 2;
	size *= sizeof(TCHAR);
	}

	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size,
		&ds);
	name = Tcl_DStringValue(&ds);
	if (!pattern || Tcl_StringMatch(name, pattern)) {
	    result = Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
974
975
976
977
978
979
980
981

982
983
984
985
986



987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002

1003
1004
1005
1006
1007
1008
1009
932
933
934
935
936
937
938

939
940
941
942


943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960

961
962
963
964
965
966
967
968







-
+



-
-
+
+
+















-
+







    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Key to open. */
    REGSAM mode,		/* Access mode. */
    int flags,			/* 0 or REG_CREATE. */
    HKEY *keyPtr)		/* Returned HKEY. */
{
    char *keyName, *buffer, *hostName;
    int length;
    size_t length;
    HKEY rootKey;
    DWORD result;

    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc((unsigned int) length + 1);
    keyName = Tcl_GetString(keyNameObj);
    length = keyNameObj->length;
    buffer = Tcl_Alloc(length + 1);
    strcpy(buffer, keyName);

    result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
    if (result == TCL_OK) {
	result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
	if (result != ERROR_SUCCESS) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("unable to open key: ", -1));
	    AppendSystemError(interp, result);
	    result = TCL_ERROR;
	} else {
	    result = TCL_OK;
	}
    }

    ckfree(buffer);
    Tcl_Free(buffer);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
1035
1036
1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054

1055


1056
1057
1058


1059
1060
1061
1062
1063
1064

1065
1066
1067
1068

1069
1070

1071


1072
1073
1074
1075
1076
1077
1078
994
995
996
997
998
999
1000

1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014

1015
1016
1017
1018

1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030

1031
1032
1033
1034

1035
1036
1037
1038
1039
1040
1041
1042
1043







-
+












+
-
+
+


-
+
+






+



-
+


+
-
+
+








    /*
     * Attempt to open the root key on a remote host if necessary.
     */

    if (hostName) {
	hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf);
	result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,
	result = RegConnectRegistry((TCHAR *)hostName, rootKey,
		&rootKey);
	Tcl_DStringFree(&buf);
	if (result != ERROR_SUCCESS) {
	    return result;
	}
    }

    /*
     * Now open the specified key with the requested permissions. Note that
     * this key must be closed by the caller.
     */

    if (keyName) {
    keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
	keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
    }
    if (flags & REG_CREATE) {
	DWORD create;
	result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,

	result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL,
		REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
    } else if (rootKey == HKEY_PERFORMANCE_DATA) {
	/*
	 * Here we fudge it for this special root key. See MSDN for more info
	 * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
	 */

	*keyPtr = HKEY_PERFORMANCE_DATA;
	result = ERROR_SUCCESS;
    } else {
	result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
	result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode,
		keyPtr);
    }
    if (keyName) {
    Tcl_DStringFree(&buf);
	Tcl_DStringFree(&buf);
    }

    /*
     * Be sure to close the root key since we are done with it now.
     */

    if (hostName) {
	RegCloseKey(rootKey);
1125
1126
1127
1128
1129
1130
1131
1132
1133



1134
1135
1136
1137
1138
1139
1140
1090
1091
1092
1093
1094
1095
1096


1097
1098
1099
1100
1101
1102
1103
1104
1105
1106







-
-
+
+
+







		}
	    }
	}
    } else {
	rootName = name;
    }
    if (!rootName) {
	Tcl_AppendResult(interp, "bad key \"", name,
		"\": must start with a valid root", NULL);
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"bad key \"%s\": must start with a valid root", name));
	Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL);
	return TCL_ERROR;
    }

    /*
     * Split the root into root and subkey portions.
     */

1178
1179
1180
1181
1182
1183
1184
1185

1186

1187
1188
1189
1190



1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201


1202
1203
1204
1205
1206
1207

1208
1209

1210
1211
1212
1213
1214
1215
1216
1217


1218

















1219


1220
1221
1222


1223
1224
1225
1226
1227
1228
1229
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169


1170
1171
1172
1173
1174
1175
1176

1177

1178
1179
1180
1181
1182
1183
1184
1185


1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205

1206
1207
1208
1209

1210
1211
1212
1213
1214
1215
1216
1217
1218







-
+

+




+
+
+









-
-
+
+





-
+
-

+






-
-
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+


-
+
+







 *
 *----------------------------------------------------------------------
 */

static DWORD
RecursiveDeleteKey(
    HKEY startKey,		/* Parent of key to be deleted. */
    CONST char *keyName)	/* Name of key to be deleted in external
    const TCHAR *keyName,	/* Name of key to be deleted in external
				 * encoding, not UTF. */
    REGSAM mode)		/* Mode flags to pass. */
{
    DWORD result, size;
    Tcl_DString subkey;
    HKEY hKey;
    REGSAM saveMode = mode;
    static int checkExProc = 0;
    static FARPROC regDeleteKeyExProc = NULL;

    /*
     * Do not allow NULL or empty key name.
     */

    if (!keyName || *keyName == '\0') {
	return ERROR_BADKEY;
    }

    result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
	    KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
    mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
    result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey);
    if (result != ERROR_SUCCESS) {
	return result;
    }

    Tcl_DStringInit(&subkey);
    Tcl_DStringSetLength(&subkey,
    Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR)));
	    (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH));

    mode = saveMode;
    while (result == ERROR_SUCCESS) {
	/*
	 * Always get index 0 because key deletion changes ordering.
	 */

	size = MAX_KEY_LENGTH;
	result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
		Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
	result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey),
		&size, NULL, NULL, NULL, NULL);
	if (result == ERROR_NO_MORE_ITEMS) {
	    /*
	     * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we
	     * can't compile with it in. We need to check for it at runtime
	     * and use it if we find it.
	     */

	    if (mode && !checkExProc) {
		HMODULE handle;

		checkExProc = 1;
		handle = GetModuleHandle(TEXT("ADVAPI32"));
		regDeleteKeyExProc = (FARPROC)
			GetProcAddress(handle, "RegDeleteKeyExW");
	    }
	    if (mode && regDeleteKeyExProc) {
		result = regDeleteKeyExProc(startKey, keyName, mode, 0);
	    } else {
	    result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
		result = RegDeleteKey(startKey, keyName);
	    }
	    break;
	} else if (result == ERROR_SUCCESS) {
	    result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
	    result = RecursiveDeleteKey(hKey,
		    (const TCHAR *) Tcl_DStringValue(&subkey), mode);
	}
    }
    Tcl_DStringFree(&subkey);
    RegCloseKey(hKey);
    return result;
}

1247
1248
1249
1250
1251
1252
1253
1254


1255
1256

1257
1258
1259
1260

1261
1262
1263
1264
1265
1266
1267

1268
1269
1270
1271

1272

1273
1274
1275
1276


1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289


1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309



1310

1311
1312
1313

1314
1315
1316
1317
1318
1319

1320
1321
1322
1323
1324
1325


1326
1327
1328
1329
1330
1331

1332

1333

1334
1335
1336

1337
1338
1339
1340

1341
1342
1343
1344
1345


1346
1347
1348

1349
1350
1351
1352
1353
1354
1355
1356



1357
1358
1359
1360
1361
1362
1363
1236
1237
1238
1239
1240
1241
1242

1243
1244
1245
1246
1247
1248
1249


1250
1251
1252
1253
1254
1255
1256

1257
1258
1259
1260
1261
1262

1263
1264
1265
1266

1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279


1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304

1305
1306
1307

1308



1309
1310

1311
1312
1313
1314
1315


1316
1317
1318
1319
1320
1321
1322

1323
1324
1325

1326
1327
1328

1329
1330
1331


1332

1333
1334


1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345



1346
1347
1348
1349
1350
1351
1352
1353
1354
1355







-
+
+


+


-
-
+






-
+




+
-
+



-
+
+











-
-
+
+




















+
+
+
-
+


-
+
-
-
-


-
+




-
-
+
+





-
+

+
-
+


-
+


-
-
+
-


-
-
+
+



+





-
-
-
+
+
+








static int
SetValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj,	/* Name of value to set. */
    Tcl_Obj *dataObj,		/* Data to be written. */
    Tcl_Obj *typeObj)		/* Type of data to be written. */
    Tcl_Obj *typeObj,		/* Type of data to be written. */
    REGSAM mode)		/* Mode flags to pass. */
{
    int type;
    size_t length;
    DWORD result;
    HKEY key;
    int length;
    char *valueName;
    const char *valueName;
    Tcl_DString nameBuf;

    if (typeObj == NULL) {
	type = REG_SZ;
    } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
	    0, (int *) &type) != TCL_OK) {
	if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
	if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }
    mode |= KEY_ALL_ACCESS;
    if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
    if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
	return TCL_ERROR;
    }

    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    valueName = Tcl_GetString(valueNameObj);
    length = valueNameObj->length;
    valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);

    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
	int value;

	if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	value = ConvertDWORD((DWORD)type, (DWORD)value);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
	value = ConvertDWORD((DWORD) type, (DWORD) value);
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) &value, sizeof(DWORD));
    } else if (type == REG_MULTI_SZ) {
	Tcl_DString data, buf;
	int objc, i;
	Tcl_Obj **objv;

	if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	/*
	 * Append the elements as null terminated strings. Note that we must
	 * not assume the length of the string in case there are embedded
	 * nulls, which aren't allowed in REG_MULTI_SZ values.
	 */

	Tcl_DStringInit(&data);
	for (i = 0; i < objc; i++) {
	    const char *bytes = Tcl_GetString(objv[i]);

	    length = objv[i]->length;
	    Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
	    Tcl_DStringAppend(&data, bytes, length);

	    /*
	     * Add a null character to separate this value from the next. We
	     * Add a null character to separate this value from the next.
	     * accomplish this by growing the string by one byte. Since the
	     * DString always tacks on an extra null byte, the new byte will
	     * already be set to null.
	     */

	    Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
	    Tcl_DStringAppend(&data, "", 1);	/* NUL-terminated string */
	}

	Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
		&buf);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
                (DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
		(DWORD) Tcl_DStringLength(&buf));
	Tcl_DStringFree(&data);
	Tcl_DStringFree(&buf);
    } else if (type == REG_SZ || type == REG_EXPAND_SZ) {
	Tcl_DString buf;
	CONST char *data = Tcl_GetStringFromObj(dataObj, &length);
	const char *data = Tcl_GetString(dataObj);

	length = dataObj->length;
	data = Tcl_WinUtfToTChar(data, length, &buf);
	data = (char *) Tcl_WinUtfToTChar(data, length, &buf);

	/*
	 * Include the null in the length, padding if needed for Unicode.
	 * Include the null in the length, padding if needed for WCHAR.
	 */

	if (regWinProcs->useWide) {
	    Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
	Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
	}
	length = Tcl_DStringLength(&buf) + 1;

	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
                (DWORD) type, (BYTE *) data, (DWORD) length);
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, (BYTE *) data, (DWORD) length);
	Tcl_DStringFree(&buf);
    } else {
	BYTE *data;
	int bytelength;

	/*
	 * Store binary data in the registry.
	 */

	data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
                (DWORD) type, data, (DWORD) length);
	data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength);
	result = RegSetValueEx(key, (TCHAR *) valueName, 0,
		(DWORD) type, data, (DWORD) bytelength);
    }

    Tcl_DStringFree(&nameBuf);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {
	Tcl_SetObjResult(interp,
1385
1386
1387
1388
1389
1390
1391
1392

1393
1394
1395
1396
1397
1398



1399
1400

1401
1402

1403
1404

1405
1406
1407
1408




1409
1410
1411

1412
1413

1414
1415
1416
1417
1418
1419
1420





1421
1422
1423
1424
1425
1426
1427
1428


1429
1430
1431
1432


1433
1434
1435
1436
1437
1438
1439
1377
1378
1379
1380
1381
1382
1383

1384
1385
1386
1387



1388
1389
1390
1391

1392


1393


1394




1395
1396
1397
1398



1399
1400

1401
1402
1403
1404
1405



1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417

1418
1419
1420
1421


1422
1423
1424
1425
1426
1427
1428
1429
1430







-
+



-
-
-
+
+
+

-
+
-
-
+
-
-
+
-
-
-
-
+
+
+
+
-
-
-
+

-
+




-
-
-
+
+
+
+
+







-
+
+


-
-
+
+







 *----------------------------------------------------------------------
 */

static int
BroadcastValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[])	/* Argument values. */
    Tcl_Obj *const objv[])	/* Argument values. */
{
    LRESULT result;
    DWORD_PTR sendResult;
    UINT timeout = 3000;
    int len;
    CONST char *str;
    int timeout = 3000;
    size_t len;
    const char *str;
    Tcl_Obj *objPtr;

    WCHAR *wstr;
    if ((objc != 3) && (objc != 5)) {
	Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
    Tcl_DString ds;
	return TCL_ERROR;
    }


    if (objc > 3) {
	str = Tcl_GetStringFromObj(objv[3], &len);
	if ((len < 2) || (*str != '-')
    if (objc == 3) {
	str = Tcl_GetString(objv[1]);
	len = objv[1]->length;
	if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) {
		|| strncmp(str, "-timeout", (size_t) len)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	    return TCL_ERROR;
	    return TCL_BREAK;
	}
	if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) {
	if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    str = Tcl_GetStringFromObj(objv[2], &len);
    if (len == 0) {
	str = NULL;
    str = Tcl_GetString(objv[0]);
    len = objv[0]->length;
    wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds);
    if (Tcl_DStringLength(&ds) == 0) {
	wstr = NULL;
    }

    /*
     * Use the ignore the result.
     */

    result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
	    (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
	    (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);
    Tcl_DStringFree(&ds);

    objPtr = Tcl_NewObj();
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result));
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult));
    Tcl_SetObjResult(interp, objPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
1454
1455
1456
1457
1458
1459
1460
1461
1462


1463
1464
1465
1466
1467
1468
1469
1470

1471
1472

1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493


1494
1495
1496

1497
1498
1499

1500
1501

1502
1503

1504
1505
1506
1507
1508
1509
1510
1511


1512
1513
1514


1515


1516
1517
1518
1519
1520
1521
1522
1445
1446
1447
1448
1449
1450
1451


1452
1453
1454
1455
1456
1457
1458
1459
1460

1461
1462

1463
1464
1465



















1466
1467

1468

1469
1470


1471


1472
1473

1474
1475
1476
1477
1478
1479
1480


1481
1482
1483


1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495







-
-
+
+







-
+

-
+


-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
-

-
+

-
-
+
-
-
+

-
+






-
-
+
+

-
-
+
+

+
+








static void
AppendSystemError(
    Tcl_Interp *interp,		/* Current interpreter. */
    DWORD error)		/* Result code from error. */
{
    int length;
    WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
    char *msg;
    TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr;
    const char *msg;
    char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
    Tcl_DString ds;
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

    if (Tcl_IsShared(resultPtr)) {
	resultPtr = Tcl_DuplicateObj(resultPtr);
    }
    length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
    length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
	    | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
	    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
	    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr,
	    0, NULL);
    if (length == 0) {
	char *msgPtr;

	length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
		| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
		MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
		0, NULL);
	if (length > 0) {
	    wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
	    MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
		    length + 1);
	    LocalFree(msgPtr);
	}
    }
    if (length == 0) {
	if (error == ERROR_CALL_NOT_IMPLEMENTED) {
	    msg = "function not supported under Win32s";
	} else {
	    sprintf(msgBuf, "unknown error: %ld", error);
	    msg = msgBuf;
	sprintf(msgBuf, "unknown error: %ld", error);
	msg = msgBuf;
	}
    } else {
	Tcl_Encoding encoding;
	char *msgPtr;

	encoding = Tcl_GetEncoding(NULL, "unicode");
	Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
	Tcl_WinTCharToUtf(tMsgPtr, -1, &ds);
	Tcl_FreeEncoding(encoding);
	LocalFree(wMsgPtr);
	LocalFree(tMsgPtr);

	msg = Tcl_DStringValue(&ds);
	msgPtr = Tcl_DStringValue(&ds);
	length = Tcl_DStringLength(&ds);

	/*
	 * Trim the trailing CR/LF from the system message.
	 */

	if (msg[length-1] == '\n') {
	    msg[--length] = 0;
	if (msgPtr[length-1] == '\n') {
	    --length;
	}
	if (msg[length-1] == '\r') {
	    msg[--length] = 0;
	if (msgPtr[length-1] == '\r') {
	    --length;
	}
	msgPtr[length] = 0;
	msg = msgPtr;
    }

    sprintf(id, "%ld", error);
    Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
    Tcl_AppendToObj(resultPtr, msg, length);
    Tcl_SetObjResult(interp, resultPtr);

1543
1544
1545
1546
1547
1548
1549
1550

1551
1552
1553
1554
1555
1556

1557

1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1516
1517
1518
1519
1520
1521
1522

1523
1524
1525
1526
1527
1528
1529
1530

1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541







-
+






+
-
+










 */

static DWORD
ConvertDWORD(
    DWORD type,			/* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
    DWORD value)		/* The value to be converted. */
{
    DWORD order = 1;
    const DWORD order = 1;
    DWORD localType;

    /*
     * Check to see if the low bit is in the first byte.
     */

    localType = (*((const char *) &order) == 1)
    localType = (*((char*) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
	    ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
    return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */