← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/fcl-registry/src/winreg.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/fcl-registry/src/winreg.inc
 
1
{******************************************************************************
 
2
                                  TRegistry
 
3
 ******************************************************************************}
 
4
 
 
5
Procedure TRegistry.SysRegCreate;
 
6
begin
 
7
  FStringSizeIncludesNull:=True;
 
8
end;
 
9
 
 
10
Procedure TRegistry.SysRegfree;
 
11
 
 
12
begin
 
13
end;
 
14
 
 
15
Function PrepKey(Const S : String) : pChar;
 
16
 
 
17
begin
 
18
  If (S[1]<>'\') then
 
19
    Result:=@S[1]
 
20
  else
 
21
    Result:=@S[2];
 
22
end;
 
23
 
 
24
Function RelativeKey(Const S : String) : Boolean;
 
25
 
 
26
begin
 
27
  Result:=(S='') or (S[1]<>'\')
 
28
end;
 
29
 
 
30
 
 
31
function TRegistry.sysCreateKey(const Key: String): Boolean;
 
32
Var
 
33
  P: PChar;
 
34
  Disposition: Dword;
 
35
  Handle: HKEY;
 
36
  SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES;
 
37
 
 
38
begin
 
39
  SecurityAttributes := Nil;
 
40
  P:=PrepKey(Key);
 
41
  Result:=RegCreateKeyExA(GetBaseKey(RelativeKey(Key)),
 
42
                         P,
 
43
                         0,
 
44
                         '',
 
45
                         REG_OPTION_NON_VOLATILE,
 
46
                         KEY_ALL_ACCESS,
 
47
                         SecurityAttributes,
 
48
                         Handle,
 
49
                         @Disposition) = ERROR_SUCCESS;
 
50
  RegCloseKey(Handle);
 
51
end;
 
52
 
 
53
function TRegistry.DeleteKey(const Key: String): Boolean;
 
54
 
 
55
Var
 
56
  P: PChar;
 
57
begin
 
58
  P:=PRepKey(Key);
 
59
  Result:=RegDeleteKeyA(GetBaseKey(RelativeKey(Key)),P)=ERROR_SUCCESS;
 
60
end;
 
61
 
 
62
function TRegistry.DeleteValue(const Name: String): Boolean;
 
63
begin
 
64
  Result := RegDeleteValueA(fCurrentKey, @Name[1]) = ERROR_SUCCESS;
 
65
end;
 
66
 
 
67
function TRegistry.SysGetData(const Name: String; Buffer: Pointer;
 
68
          BufSize: Integer; var RegData: TRegDataType): Integer;
 
69
Var
 
70
  P: PChar;
 
71
  RD : DWord;
 
72
 
 
73
begin
 
74
  P := @Name[1];
 
75
  If RegQueryValueExA(fCurrentKey,P,Nil,
 
76
                      @RD,Buffer,lpdword(@BufSize))<>ERROR_SUCCESS Then
 
77
    Result:=-1
 
78
  else
 
79
    begin
 
80
    If (RD=REG_SZ) then
 
81
      RegData:=rdString
 
82
    else if (RD=REG_EXPAND_SZ) then
 
83
      Regdata:=rdExpandString
 
84
    else if (RD=REG_DWORD) then
 
85
      RegData:=rdInteger
 
86
    else if (RD=REG_BINARY) then
 
87
      RegData:=rdBinary
 
88
    else
 
89
      RegData:=rdUnknown;
 
90
    Result:=BufSize;
 
91
    end;
 
92
end;
 
93
 
 
94
function TRegistry.GetDataInfo(const ValueName: String; var Value: TRegDataInfo): Boolean;
 
95
 
 
96
Var
 
97
  P: PChar;
 
98
 
 
99
begin
 
100
  P:=@ValueName[1];
 
101
  With Value do
 
102
    Result:=RegQueryValueExA(fCurrentKey,P,Nil,lpdword(@RegData),Nil,lpdword(@DataSize))=ERROR_SUCCESS;
 
103
  If Not Result Then
 
104
    begin
 
105
    Value.RegData := rdUnknown;
 
106
    Value.DataSize := 0
 
107
    end
 
108
end;
 
109
 
 
110
 
 
111
function TRegistry.GetKey(const Key: String): HKEY;
 
112
var
 
113
  S : string;
 
114
  Rel : Boolean;
 
115
begin
 
116
  Result:=0;
 
117
  S:=Key;
 
118
  Rel:=RelativeKey(S);
 
119
  if not(Rel) then
 
120
    Delete(S,1,1);
 
121
{$ifdef WinCE}
 
122
  RegOpenKeyEx(GetBaseKey(Rel),PWideChar(WideString(S)),0,FAccess,Result);
 
123
{$else WinCE}
 
124
  RegOpenKeyEx(GetBaseKey(Rel),PChar(S),0,FAccess,Result);
 
125
{$endif WinCE}
 
126
end;
 
127
 
 
128
 
 
129
function TRegistry.GetKeyInfo(var Value: TRegKeyInfo): Boolean;
 
130
var
 
131
  winFileTime: Windows.FILETIME;
 
132
  sysTime: TSystemTime;
 
133
begin
 
134
  FillChar(Value, SizeOf(Value), 0);
 
135
  With Value do
 
136
    Result:=RegQueryInfoKeyA(CurrentKey,nil,nil,nil,lpdword(@NumSubKeys),
 
137
              lpdword(@MaxSubKeyLen),nil,lpdword(@NumValues),lpdword(@MaxValueLen),
 
138
              lpdword(@MaxDataLen),nil,@winFileTime)=ERROR_SUCCESS;
 
139
  if Result then
 
140
  begin
 
141
    FileTimeToSystemTime(@winFileTime, @sysTime);
 
142
    Value.FileTime := SystemTimeToDateTime(sysTime);
 
143
  end;
 
144
end;
 
145
 
 
146
 
 
147
function TRegistry.KeyExists(const Key: string): Boolean;
 
148
var
 
149
  KeyHandle : HKEY;
 
150
  OldAccess : LONG;
 
151
begin
 
152
  Result:=false;
 
153
  OldAccess:=FAccess;
 
154
  try
 
155
    FAccess:=KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS or STANDARD_RIGHTS_READ;
 
156
    KeyHandle:=GetKey(Key);
 
157
    if KeyHandle<>0 then
 
158
      begin
 
159
        RegCloseKey(KeyHandle);
 
160
        Result:=true;
 
161
      end;
 
162
  finally
 
163
    FAccess:=OldAccess;
 
164
  end;
 
165
end;
 
166
 
 
167
 
 
168
function TRegistry.LoadKey(const Key, FileName: string): Boolean;
 
169
begin
 
170
  Result := False;
 
171
end;
 
172
 
 
173
 
 
174
function TRegistry.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
 
175
 
 
176
Var
 
177
  P: PChar;
 
178
  Handle: HKEY;
 
179
  Disposition: Integer;
 
180
  SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES;
 
181
 
 
182
begin
 
183
  SecurityAttributes := Nil;
 
184
  P:=PrepKey(Key);
 
185
  If CanCreate then
 
186
    begin
 
187
    Handle:=0;
 
188
    Result:=RegCreateKeyExA(GetBaseKey(RelativeKey(Key)),P,0,'',
 
189
 
 
190
                           REG_OPTION_NON_VOLATILE,
 
191
                           fAccess,SecurityAttributes,Handle,
 
192
                           pdword(@Disposition))=ERROR_SUCCESS
 
193
 
 
194
    end
 
195
  else
 
196
    Result:=RegOpenKeyExA(GetBaseKey(RelativeKey(Key)),
 
197
                         P,0,fAccess,Handle)=ERROR_SUCCESS;
 
198
  If Result then
 
199
    fCurrentKey:=Handle;
 
200
end;
 
201
 
 
202
function TRegistry.OpenKeyReadOnly(const Key: string): Boolean;
 
203
 
 
204
Var
 
205
  P: PChar;
 
206
  Handle: HKEY;
 
207
 
 
208
begin
 
209
  P:=PrepKey(Key);
 
210
  Result := RegOpenKeyExA(GetBaseKey(RelativeKey(Key)),P,0,KEY_READ,Handle) = 0;
 
211
  If Result Then
 
212
    fCurrentKey := Handle;
 
213
end;
 
214
 
 
215
function TRegistry.RegistryConnect(const UNCName: string): Boolean;
 
216
begin
 
217
  Result := False;
 
218
end;
 
219
 
 
220
function TRegistry.ReplaceKey(const Key, FileName, BackUpFileName: string): Boolean;
 
221
begin
 
222
  Result := False;
 
223
end;
 
224
 
 
225
function TRegistry.RestoreKey(const Key, FileName: string): Boolean;
 
226
begin
 
227
  Result := False;
 
228
end;
 
229
 
 
230
function TRegistry.SaveKey(const Key, FileName: string): Boolean;
 
231
begin
 
232
  Result := False;
 
233
end;
 
234
 
 
235
function TRegistry.UnLoadKey(const Key: string): Boolean;
 
236
begin
 
237
  Result := false;
 
238
end;
 
239
 
 
240
function TRegistry.ValueExists(const Name: string): Boolean;
 
241
 
 
242
var
 
243
  Info : TRegDataInfo;
 
244
 
 
245
begin
 
246
  Result:=GetDataInfo(Name,Info);
 
247
end;
 
248
 
 
249
procedure TRegistry.CloseKey;
 
250
begin
 
251
  If (CurrentKey<>0) then
 
252
    begin
 
253
    if LazyWrite then
 
254
      RegCloseKey(CurrentKey)
 
255
    else
 
256
      RegFlushKey(CurrentKey);
 
257
    fCurrentKey:=0;
 
258
    end
 
259
end;
 
260
 
 
261
procedure TRegistry.ChangeKey(Value: HKey; const Path: String);
 
262
begin
 
263
  CloseKey;
 
264
  FCurrentKey:=Value;
 
265
  FCurrentPath:=Path;
 
266
end;
 
267
 
 
268
procedure TRegistry.GetKeyNames(Strings: TStrings);
 
269
 
 
270
Var
 
271
  L : Cardinal;
 
272
  I: Integer;
 
273
  Info: TRegKeyInfo;
 
274
  P : PChar;
 
275
 
 
276
begin
 
277
   Strings.Clear;
 
278
   if GetKeyInfo(Info) then
 
279
     begin
 
280
     L:=Info.MaxSubKeyLen+1;
 
281
     GetMem(P,L);
 
282
     Try
 
283
       for I:=0 to Info.NumSubKeys-1 do
 
284
         begin
 
285
         L:=Info.MaxSubKeyLen+1;
 
286
         RegEnumKeyExA(CurrentKey,I,P,L,Nil,Nil,Nil,Nil);
 
287
         Strings.Add(StrPas(P));
 
288
         end;
 
289
     Finally
 
290
       FreeMem(P);
 
291
     end;
 
292
     end;
 
293
end;
 
294
 
 
295
procedure TRegistry.GetValueNames(Strings: TStrings);
 
296
 
 
297
Var
 
298
  L : Cardinal;
 
299
  I: Integer;
 
300
  Info: TRegKeyInfo;
 
301
  P : PChar;
 
302
 
 
303
begin
 
304
   Strings.Clear;
 
305
   if GetKeyInfo(Info) then
 
306
     begin
 
307
     L:=Info.MaxValueLen+1;
 
308
     GetMem(P,L);
 
309
     Try
 
310
       for I:=0 to Info.NumValues-1 do
 
311
         begin
 
312
         L:=Info.MaxValueLen+1;
 
313
         RegEnumValueA(CurrentKey,I,P,L,Nil,Nil,Nil,Nil);
 
314
         Strings.Add(StrPas(P));
 
315
         end;
 
316
     Finally
 
317
       FreeMem(P);
 
318
     end;
 
319
     end;
 
320
 
 
321
end;
 
322
 
 
323
Function TRegistry.SysPutData(const Name: string; Buffer: Pointer;
 
324
  BufSize: Integer; RegData: TRegDataType) : Boolean;
 
325
 
 
326
Var
 
327
  P: PChar;
 
328
  RegDataType: DWORD;
 
329
 
 
330
begin
 
331
  Case RegData of
 
332
    rdUnknown      : RegDataType:=REG_NONE;
 
333
    rdString       : RegDataType:=REG_SZ;
 
334
    rdExpandString : RegDataType:=REG_EXPAND_SZ;
 
335
    rdInteger      : RegDataType:=REG_DWORD;
 
336
    rdBinary       : RegDataType:=REG_BINARY;
 
337
  end;
 
338
  P:=@Name[1];
 
339
  Result:=RegSetValueExA(fCurrentKey,P,0,RegDataType,Buffer,BufSize)=ERROR_SUCCESS;
 
340
end;
 
341
 
 
342
procedure TRegistry.RenameValue(const OldName, NewName: string);
 
343
 
 
344
var
 
345
  L: Integer;
 
346
  InfoO,InfoN : TRegDataInfo;
 
347
  D : TRegDataType;
 
348
  P: PChar;
 
349
 
 
350
begin
 
351
  If GetDataInfo(OldName,InfoO) and Not GetDataInfo(NewName,InfoN) then
 
352
    begin
 
353
    L:=InfoO.DataSize;
 
354
    if L>0 then
 
355
      begin
 
356
      GetMem(P,L);
 
357
      try
 
358
        L:=GetData(OldName,P,L,D);
 
359
        If SysPutData(NewName,P,L,D) then
 
360
          DeleteValue(OldName);
 
361
      finally
 
362
        FreeMem(P);
 
363
      end;
 
364
      end;
 
365
    end;
 
366
end;
 
367
 
 
368
procedure TRegistry.SetCurrentKey(Value: HKEY);
 
369
begin
 
370
  fCurrentKey := Value;
 
371
end;
 
372
 
 
373
procedure TRegistry.SetRootKey(Value: HKEY);
 
374
begin
 
375
  fRootKey := Value;
 
376
end;
 
377