Context Navigation

xmlreg.pp

Last change on this file was 13, checked in by chronos, 10 years ago
Added: Basic parsing of "Depends on" expressions.
File size: 16.8 KB

Line
1	{$mode objfpc}
2	{$h+}
3
4	unit xmlreg;
5
6	Interface
7
8	uses
9	sysutils,classes,dom,xmlread,xmlwrite;
10
11	Type
12
13	TDataType = (dtUnknown,dtDWORD,dtString,dtBinary);
14	TDataInfo = record
15	DataType : TDataType;
16	DataSize : Integer;
17	end;
18
19	TKeyInfo = record
20	SubKeys,
21	SubKeyLen,
22	Values,
23	ValueLen,
24	DataLen : Integer;
25	FTime : TDateTime;
26	end;
27
28
29	{ TXmlRegistry }
30
31	TXmlRegistry = Class(TObject)
32	Private
33	FAutoFlush,
34	FDirty : Boolean;
35	FFileName : String;
36	FRootKey : String;
37	FDocument : TXMLDocument;
38	FCurrentElement : TDomElement;
39	FCurrentKey : String;
40	Procedure SetFileName(Value : String);
41	Protected
42	Procedure LoadFromStream(S : TStream);
43	Function NormalizeKey(KeyPath : String) : String;
44	Procedure CreateEmptyDoc;
45	Function FindKey (S : String) : TDomElement;
46	Function FindSubKey (S : String; N : TDomElement) : TDomElement;
47	Function CreateSubKey (S : String; N : TDomElement) : TDomElement;
48	Function FindValueKey (S : String) : TDomElement;
49	Function CreateValueKey (S : String) : TDomElement;
50	Function BufToHex(Const Buf; Len : Integer) : String;
51	Function hexToBuf(Const Str : String; Var Buf; Var Len : Integer ) : Integer;
52	Procedure MaybeFlush;
53	Property Document : TXMLDocument Read FDocument;
54	Property Dirty : Boolean Read FDirty write FDirty;
55	Public
56	Constructor Create(AFileName : String);
57	Destructor Destroy;override;
58	Function SetKey(KeyPath : String; AllowCreate : Boolean) : Boolean ;
59	Procedure SetRootKey(Value : String);
60	Function DeleteKey(KeyPath : String) : Boolean;
61	Function CreateKey(KeyPath : String) : Boolean;
62	Function GetValueSize(Name : String) : Integer;
63	Function GetValueType(Name : String) : TDataType;
64	Function GetValueInfo(Name : String; Var Info : TDataInfo) : Boolean;
65	Function GetKeyInfo(Var Info : TKeyInfo) : Boolean;
66	Function EnumSubKeys(List : TStrings) : Integer;
67	Function EnumValues(List : TStrings) : Integer;
68	Function KeyExists(KeyPath : String) : Boolean;
69	Function ValueExists(ValueName : String) : Boolean;
70	Function RenameValue(Const OldName,NewName : String) : Boolean;
71	Function DeleteValue(S : String) : Boolean;
72	Procedure Flush;
73	Procedure Load;
74	Function GetValueData(Name : String; Var DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
75	Function SetValueData(Name : String; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
76	Property FileName : String Read FFileName Write SetFileName;
77	Property RootKey : String Read FRootKey Write SetRootkey;
78	Property AutoFlush : Boolean Read FAutoFlush Write FAutoFlush;
79	end;
80
81	// used Key types
82
83	Const
84	SXmlReg = 'XMLReg';
85	SKey = 'Key';
86	SValue = 'Value';
87	SName = 'Name';
88	SType = 'Type';
89	SData = 'Data';
90
91	Implementation
92
93
94	Constructor TXmlRegistry.Create(AFileName : String);
95
96	begin
97	FFileName:=AFileName;
98	FautoFlush:=True;
99	If (AFileName<>'') then
100	Load
101	else
102	CreateEmptyDoc;
103	end;
104
105	destructor TXmlRegistry.Destroy;
106	begin
107	if Assigned(FDocument) then FDocument.Free;
108	inherited Destroy;
109	end;
110
111	Procedure TXmlRegistry.SetFileName(Value : String);
112
113	begin
114	If Value<>FFileName then
115	begin
116	FFilename:=Value;
117	Flush;
118	end;
119	end;
120
121	Procedure TXmlRegistry.CreateEmptyDoc;
122
123	Const
124	template = '<?xml version="1.0" encoding="ISO8859-1"?>'+LineEnding+
125	'<'+SXMLReg+'>'+LineEnding+
126	'</'+SXMLReg+'>'+LineEnding;
127
128	Var
129	S : TStream;
130
131	begin
132	S:=TStringStream.Create(Template);
133	S.Seek(0,soFromBeginning);
134	Try
135	LoadFromStream(S);
136	Finally
137	S.Free;
138	end;
139	end;
140
141	Function TXmlRegistry.NormalizeKey(KeyPath : String) : String;
142
143	Var
144	L : Integer;
145
146	begin
147	Result:=StringReplace(KeyPath,'\','/',[rfReplaceAll]);
148	L:=Length(Result);
149	If (L>0) and (Result[L]<>'/') then
150	Result:=Result+'/';
151	If (L>0) and (Result[1]<>'/') then
152	Result:='/' + Result;
153	end;
154
155	Function TXmlRegistry.SetKey(KeyPath : String; AllowCreate : Boolean) : boolean;
156
157	Var
158	SubKey,ResultKey : String;
159	P : Integer;
160	Node,Node2 : TDomElement;
161
162	begin
163	Result:=(Length(KeyPath)>0);
164	If Not Result then
165	Exit;
166	KeyPath:=NormalizeKey(KeyPath);
167	If (FCurrentElement<>nil) then
168	begin
169	Delete(Keypath,1,1);
170	Node:=FCurrentElement;
171	Resultkey:=FCurrentKey;
172	end
173	else
174	begin
175	Delete(Keypath,1,1);
176	Node:=FDocument.DocumentElement;
177	If (FRootKey<>'') then
178	KeyPath:=FRootKey+KeyPath;
179	ResultKey:='';
180	end;
181	Result:=True;
182	repeat
183	P:=Pos('/',KeyPath);
184	If (P<>0) then
185	begin
186	SubKey:=Copy(KeyPath,1,P-1);
187	Delete(KeyPath,1,P);
188	Node2:=FindSubKey(SubKey,Node);
189	Result:=(Node2<>Nil);
190	If Result then
191	Node:=Node2
192	else
193	begin
194	If AllowCreate then
195	Begin
196	Node2:=CreateSubKey(SubKey,Node);
197	Result:=Node2<>Nil;
198	If Result Then
199	Node:=Node2;
200	end;
201	end;
202	If Result then
203	ResultKey:=ResultKey+SubKey+'/';
204	end;
205	Until (Not Result) or (Length(KeyPath)=0);
206	If Result then
207	begin
208	FCurrentkey:=ResultKey;
209	FCurrentElement:=Node;
210	end;
211	MaybeFlush;
212	end;
213
214	Procedure TXmlRegistry.SetRootKey(Value : String);
215
216	begin
217	FRootKey:=NormalizeKey(Value);
218	If (Length(FRootKey)>1) and (FRootKey[1]='/') then
219	Delete(FRootKey,1,1);
220	FCurrentKey:='';
221	FCurrentElement:=Nil;
222	end;
223
224	Function TXmlRegistry.DeleteKey(KeyPath : String) : Boolean;
225
226	Var
227	N : TDomElement;
228
229	begin
230	N:=FindKey(KeyPath);
231	Result:=(N<>Nil);
232	If Result then
233	begin
234	(N.ParentNode as TDomElement).RemoveChild(N);
235	FDirty:=True;
236	MaybeFlush;
237	end;
238	end;
239
240	Function TXmlRegistry.CreateKey(KeyPath : String) : Boolean;
241
242	Var
243	SubKey : String;
244	P : Integer;
245	Node,Node2 : TDomElement;
246
247	begin
248	Result:=(Length(KeyPath)>0);
249	If Not Result then
250	Exit;
251	KeyPath:=NormalizeKey(KeyPath);
252	If (FCurrentElement<>nil) then
253	begin
254	Delete(Keypath,1,1);
255	Node:=FCurrentElement;
256	end
257	else
258	begin
259	Delete(Keypath,1,1);
260	Node:=FDocument.DocumentElement;
261	If (FRootKey<>'') then
262	KeyPath:=FRootKey+KeyPath;
263	end;
264	Result:=True;
265	repeat
266	P:=Pos('/',KeyPath);
267	If (P<>0) then
268	begin
269	SubKey:=Copy(KeyPath,1,P-1);
270	Delete(KeyPath,1,P);
271	Node2:=FindSubKey(SubKey,Node);
272	Result:=(Node2<>Nil);
273	If Result then
274	Node:=Node2
275	else
276	begin
277	Node2:=CreateSubKey(SubKey,Node);
278	Result:=Node2<>Nil;
279	Node:=Node2
280	end;
281	end;
282	Until (Not Result) or (Length(KeyPath)=0);
283	MaybeFlush;
284	end;
285
286	Function TXmlRegistry.GetValueData(Name : String; Var DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
287
288	Type
289	PCardinal = ^Cardinal;
290
291	Var
292	Node : TDomElement;
293	DataNode : TDomNode;
294	ND : Integer;
295	S : AnsiString;
296	HasData: Boolean;
297	IntValue: Integer;
298	begin
299	Node:=FindValueKey(Name);
300	Result:=Node<>Nil;
301	If Result then
302	begin
303	DataNode:=Node.FirstChild;
304	HasData:=Assigned(DataNode) and (DataNode.NodeType=TEXT_NODE);
305	ND:=StrToIntDef(Node[Stype],0);
306	Result:=ND<=Ord(High(TDataType));
307	If Result then
308	begin
309	DataType:=TDataType(ND);
310	Case DataType of
311	dtDWORD : begin // DataNode is required
312	if HasData and TryStrToInt(DataNode.NodeValue,IntValue) then
313	begin
314	PCardinal(@Data)^:=IntValue;
315	DataSize:=SizeOf(Cardinal);
316	end
317	else
318	Result:=False;
319	end;
320	dtString : begin // DataNode is optional
321	if HasData then
322	begin
323	S:=DataNode.NodeValue; // Convert to ansistring
324	DataSize:=Length(S);
325	if (DataSize>0) then
326	Move(S[1],Data,DataSize);
327	end
328	else
329	DataSize:=0;
330	end;
331	dtBinary : begin // DataNode is optional
332	if HasData then
333	begin
334	DataSize:=Length(DataNode.NodeValue);
335	If (DataSize>0) then
336	HexToBuf(DataNode.NodeValue,Data,DataSize);
337	end
338	else
339	DataSize:=0;
340	end;
341	end;
342	end;
343	end;
344	end;
345
346	Function TXmlRegistry.SetValueData(Name : String; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
347
348	Type
349	PCardinal = ^Cardinal;
350
351	Var
352	Node : TDomElement;
353	DataNode : TDomNode;
354	S : String;
355	begin
356	Node:=FindValueKey(Name);
357	If Node=Nil then
358	Node:=CreateValueKey(Name);
359	Result:=(Node<>Nil);
360	If Result then
361	begin
362	Node[SType]:=IntToStr(Ord(DataType));
363	DataNode:=Node.FirstChild;
364
365	Case DataType of
366	dtDWORD : S:=IntToStr(PCardinal(@Data)^);
367	dtString : SetString(S, PAnsiChar(@Data), DataSize);
368	dtBinary : S:=BufToHex(Data,DataSize);
369	else
370	s:='';
371	end;
372	if s <> '' then
373	begin
374	if DataNode=nil then
375	begin
376	// may happen if previous value was empty;
377	// XML does not handle empty textnodes.
378	DataNode:=FDocument.CreateTextNode(s);
379	Node.AppendChild(DataNode);
380	end
381	else
382	DataNode.NodeValue:=s;
383	end
384	else
385	DataNode.Free;
386	FDirty:=True;
387	MaybeFlush;
388	end;
389	end;
390
391	Function TXmlRegistry.FindSubKey (S : String; N : TDomElement) : TDomElement;
392
393	Var
394	Node : TDOMNode;
395
396	begin
397	Result:=Nil;
398	If N<>Nil then
399	begin
400	Node:=N.FirstChild;
401	While (Result=Nil) and (Assigned(Node)) do
402	begin
403	If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SKey) then
404	If CompareText(TDomElement(Node)[SName],S)=0 then
405	Result:=TDomElement(Node);
406	Node:=Node.NextSibling;
407	end;
408	end;
409	end;
410
411	Function TXmlRegistry.CreateSubKey (S : String; N : TDomElement) : TDomElement;
412
413	begin
414	Result:=FDocument.CreateElement(SKey);
415	Result[SName]:=S;
416	if N<>nil then
417	N.AppendChild(Result);
418	FDirty:=True;
419	end;
420
421	Function TXmlRegistry.FindValueKey (S : String) : TDomElement;
422
423	Var
424	Node : TDOMNode;
425
426	begin
427	If FCurrentElement<>Nil then
428	begin
429	Node:=FCurrentElement.FirstChild;
430	Result:=Nil;
431	While (Result=Nil) and (Assigned(Node)) do
432	begin
433	If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SValue) then
434	If CompareText(TDomElement(Node)[SName],S)=0 then
435	Result:=TDomElement(Node);
436	Node:=Node.NextSibling;
437	end;
438	end;
439	end;
440
441	Function TXmlRegistry.CreateValueKey (S : String) : TDomElement;
442
443	begin
444	If Assigned(FCurrentElement) then
445	begin
446	Result:=FDocument.CreateElement(SValue);
447	Result[SName]:=S;
448	// textnode to hold the value;
449	Result.AppendChild(FDocument.CreateTextNode(''));
450	FCurrentElement.AppendChild(Result);
451	FDirty:=True;
452	end
453	else
454	Result:=Nil;
455	end;
456
457	Procedure TXMLregistry.MaybeFlush;
458
459	begin
460	If FAutoFlush then
461	Flush;
462	end;
463
464	Procedure TXmlRegistry.Flush;
465
466	Var
467	S : TStream;
468
469	begin
470	If FDirty then
471	begin
472	S:=TFileStream.Create(FFileName,fmCreate);
473	Try
474	WriteXMLFile(FDocument,S);
475	FDirty:=False;
476	finally
477	S.Free;
478	end;
479	end;
480	end;
481
482
483	Procedure TXmlRegistry.Load;
484
485	Var
486	S : TStream;
487
488	begin
489	If Not FileExists(FFileName) then
490	CreateEmptyDoc
491	else
492	begin
493	S:=TFileStream.Create(FFileName,fmOpenReadWrite);
494	try
495	LoadFromStream(S);
496	finally
497	S.Free;
498	end;
499	end;
500	end;
501
502	Procedure TXmlRegistry.LoadFromStream(S : TStream);
503
504	begin
505	If Assigned(FDocument) then
506	begin
507	FDocument.Free;
508	FDocument:=Nil;
509	end;
510	ReadXMLFile(FDocument,S);
511	if (FDocument=Nil) then
512	CreateEmptyDoc;
513	SetRootKey('HKEY_CURRENT_USER');
514	FDirty:=False;
515	end;
516
517	Function TXmlRegistry.BufToHex(Const Buf; Len : Integer) : String;
518
519	Var
520	P : PByte;
521	S : String;
522	I : Integer;
523
524	begin
525	SetLength(Result,Len*2);
526	P:=@Buf;
527	For I:=0 to Len-1 do
528	begin
529	S:=HexStr(P[I],2);
530	Move(S[1],Result[I*2+1],2);
531	end;
532	end;
533
534	Function TXMLRegistry.hexToBuf(Const Str : String; Var Buf; Var Len : Integer ) : Integer;
535
536	Var
537	I : Integer;
538	P : PByte;
539	S : String;
540	B : Byte;
541	Code : Integer;
542
543	begin
544	P:=@Buf;
545	Len:= Length(Str) div 2;
546	Result:=0;
547	For I:=0 to Len-1 do
548	begin
549	S:='$'+Copy(Str,(I*2)+1,2);
550	Val(S,B,Code);
551	If Code<>0 then
552	begin
553	Inc(Result);
554	B:=0;
555	end;
556	P[I]:=B;
557	end;
558	end;
559
560	Function TXMLRegistry.DeleteValue(S : String) : Boolean;
561
562	Var
563	N : TDomElement;
564
565	begin
566	N:=FindValueKey(S);
567	Result:=(N<>Nil);
568	If Result then
569	begin
570	FCurrentElement.RemoveChild(N);
571	FDirty:=True;
572	MaybeFlush;
573	end;
574	end;
575
576	Function TXMLRegistry.GetValueSize(Name : String) : Integer;
577
578	Var
579	Info : TDataInfo;
580
581	begin
582	If GetValueInfo(Name,Info) then
583	Result:=Info.DataSize
584	else
585	Result:=-1;
586	end;
587
588	Function TXMLRegistry.GetValueType(Name : String) : TDataType;
589
590	Var
591	Info : TDataInfo;
592
593	begin
594	If GetValueInfo(Name,Info) then
595	Result:=Info.DataType
596	else
597	Result:=dtUnknown;
598	end;
599
600	Function TXMLRegistry.GetValueInfo(Name : String; Var Info : TDataInfo) : Boolean;
601
602	Var
603	N : TDomElement;
604	DN : TDomNode;
605	L : Integer;
606	S: Ansistring;
607	begin
608	N:=FindValueKey(Name);
609	Result:=(N<>Nil);
610	If Result then
611	begin
612	DN:=N.FirstChild;
613	if Assigned(DN) and (DN.NodeType=TEXT_NODE) then begin
614	S := TDOMText(DN).Data;
615	L:= Length(S);
616	end else
617	L:=0;
618	With Info do
619	begin
620	DataType:=TDataType(StrToIntDef(N[SType],0));
621	Case DataType of
622	dtUnknown : DataSize:=0;
623	dtDword : Datasize:=SizeOf(Cardinal);
624	dtString : DataSize:=L;
625	dtBinary : DataSize:=L div 2;
626	end;
627	end;
628	end;
629	end;
630
631	Function TXMLRegistry.GetKeyInfo(Var Info : TKeyInfo) : Boolean;
632
633	Var
634	Node,DataNode : TDOMNode;
635	L : Integer;
636
637	begin
638	FillChar(Info,SizeOf(Info),0);
639	Result:=FCurrentElement<>Nil;
640	If Result then
641	With Info do
642	begin
643	If (FFileName<>'') Then
644	FTime:=FileAge(FFileName);
645	Node:=FCurrentElement.FirstChild;
646	While Assigned(Node) do
647	begin
648	If (Node.NodeType=ELEMENT_NODE) then
649	If (Node.NodeName=SKey) then
650	begin
651	Inc(SubKeys);
652	L:=Length(TDomElement(Node)[SName]);
653	If (L>SubKeyLen) then
654	SubKeyLen:=L;
655	end
656	else if (Node.NodeName=SValue) then
657	begin
658	Inc(Values);
659	L:=Length(TDomElement(Node)[SName]);
660	If (L>ValueLen) then
661	ValueLen:=L;
662	DataNode:=TDomElement(Node).FirstChild;
663	If (DataNode<>Nil) and (DataNode is TDomText) then
664	Case TDataType(StrToIntDef(TDomElement(Node)[SType],0)) of
665	dtUnknown : L:=0;
666	dtDWord : L:=4;
667	DtString : L:=Length(DataNode.NodeValue);
668	dtBinary : L:=Length(DataNode.NodeValue) div 2;
669	end
670	else
671	L:=0;
672	If (L>DataLen) Then
673	DataLen:=L;
674	end;
675	Node:=Node.NextSibling;
676	end;
677	end;
678	end;
679
680	Function TXMLRegistry.EnumSubKeys(List : TStrings) : Integer;
681
682	Var
683	Node : TDOMNode;
684
685	begin
686	List.Clear;
687	Result:=0;
688	If FCurrentElement<>Nil then
689	begin
690	Node:=FCurrentElement.FirstChild;
691	While Assigned(Node) do
692	begin
693	If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SKey) then
694	List.Add(TDomElement(Node)[SName]);
695	Node:=Node.NextSibling;
696	end;
697	Result:=List.Count;
698	end;
699	end;
700
701	Function TXMLRegistry.EnumValues(List : TStrings) : Integer;
702
703	Var
704	Node : TDOMNode;
705
706	begin
707	List.Clear;
708	Result:=0;
709	If FCurrentElement<>Nil then
710	begin
711	Node:=FCurrentElement.FirstChild;
712	While Assigned(Node) do
713	begin
714	If (Node.NodeType=ELEMENT_NODE) and (Node.NodeName=SValue) then
715	List.Add(TDomElement(Node)[SName]);
716	Node:=Node.NextSibling;
717	end;
718	Result:=List.Count;
719	end;
720	end;
721
722	Function TXMLRegistry.KeyExists(KeyPath : String) : Boolean;
723
724	begin
725	Result:=FindKey(KeyPath)<>Nil;
726	end;
727
728	Function TXMLRegistry.RenameValue(Const OldName,NewName : String) : Boolean;
729
730	Var
731	N : TDomElement;
732
733	begin
734	N:=FindValueKey(OldName);
735	result:=n<>nil;
736	If (Result) then
737	begin
738	N[SName]:=NewName;
739	FDirty:=True;
740	MaybeFlush;
741	end;
742	end;
743
744	Function TXMLRegistry.FindKey (S : String) : TDomElement;
745
746	Var
747	SubKey : String;
748	P : Integer;
749	Node : TDomElement;
750
751	begin
752	Result:=Nil;
753	If (Length(S)=0) then
754	Exit;
755	S:=NormalizeKey(S);
756	If (FCurrentElement<>nil) then
757	begin
758	Delete(S,1,1);
759	Node:=FCurrentElement;
760	end
761	else
762	begin
763	Delete(S,1,1);
764	Node:=FDocument.DocumentElement;
765	If (FRootKey<>'') then
766	S:=FRootKey+S;
767	end;
768	repeat
769	P:=Pos('/',S);
770	If (P<>0) then
771	begin
772	SubKey:=Copy(S,1,P-1);
773	Delete(S,1,P);
774	Result:=FindSubKey(SubKey,Node);
775	Node:=Result;
776	end;
777	Until (Result=Nil) or (Length(S)=0);
778	end;
779
780	Function TXmlRegistry.ValueExists(ValueName : String) : Boolean;
781
782	begin
783	Result:=FindValueKey(ValueName)<>Nil;
784	end;
785
786
787	end.

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/Packages/fcl-registry/xmlreg.pp

Download in other formats: