examples/Delphi/ExDictU.pas

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

unit ExDictU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,

  StConst, StBase, StUtils, StList, StDict;

type
  TSTDlg = class(TForm)
    CreateBtn: TButton;
    ClearBtn: TButton;
    LB1: TListBox;
    Label9: TLabel;
    Edit1: TEdit;
    Label10: TLabel;
    Edit2: TEdit;
    AddBtn: TButton;
    DelBtn: TButton;
    ExistsBtn: TButton;
    UpDateBtn: TButton;
    SaveBtn: TButton;
    LoadBtn: TButton;
    OD1: TOpenDialog;
    SD1: TSaveDialog;
    Label1: TLabel;

    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure ClearBtnClick(Sender: TObject);
    procedure AddBtnClick(Sender: TObject);
    procedure DelBtnClick(Sender: TObject);
    procedure ExistsBtnClick(Sender: TObject);
    procedure CreateBtnClick(Sender: TObject);
    procedure UpDateBtnClick(Sender: TObject);
    procedure LB1Click(Sender: TObject);
    procedure LB1DblClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
    MyDD  : TStDictionary;

    function RandomData : ShortString;
    procedure UpdateButtons(DOK : Boolean);
    procedure FillListBox;
  end;

var
  STDlg: TSTDlg;

implementation

{$R *.DFM}

const
  MaxElem = 100;
  MaxLen  = 15;
  GHash   = 127;


function DDWalker(Container : TStContainer;
                  Data : TStNode;
                  OtherData : Pointer) : Boolean; far;
var
  S : ShortString;
begin
  S := ShortString(Data.Data^);
  STDlg.LB1.Items.Add(TStDictNode(Data).Name + ' = ' + S);
  Result := True;
end;

function MyLoadData(Reader : TReader) : Pointer; far;
begin
  GetMem(Result,SizeOf(ShortString));
  ShortString(Result^) := Reader.ReadString;
end;

procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
begin
  Writer.WriteString(ShortString(Data^));
end;

procedure TSTDlg.FillListBox;
begin
  LB1.Clear;
  LB1.Perform(WM_SETREDRAW,0,0);

  MyDD.Iterate(DDWalker,nil);

  LB1.Perform(WM_SETREDRAW,1,0);
  LB1.Update;
end;

procedure TSTDlg.UpdateButtons(DOK : Boolean);
begin
  ClearBtn.Enabled  := DOK;
  AddBtn.Enabled    := DOK;
  UpdateBtn.Enabled := DOK;
  ExistsBtn.Enabled := DOK;
  DelBtn.Enabled    := DOK;
  SaveBtn.Enabled   := DOK;
  LB1.Enabled       := DOK;
end;

procedure TSTDlg.FormCreate(Sender: TObject);
begin
  RegisterClasses([TStDictionary,TStDictNode]);
  UpdateButtons(False);
end;

procedure TSTDlg.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  MyDD.Free;
end;

function TSTDlg.RandomData : ShortString;
var
  Len,
  I    : Integer;
begin
  Len := Random(MaxLen)+1;
  Result[0] := Chr(Len);
  for I := 1 to Len do
    Result[I] := Chr(Random(26) + Ord('A'));
end;

procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
  I  : Integer;
  S  : ^ShortString;
begin
  Randomize;
  if Assigned(MyDD) then
    MyDD.Free;

  UpdateButtons(False);
  MyDD := TStDictionary.Create(GHash);
  MyDD.LoadData := MyLoadData;
  MyDD.StoreData := MyStoreData;
  MyDD.Hash := AnsiElfHashText;

  for I := 1 to MaxElem do
  begin
    GetMem(S,SizeOf(ShortString));
    S^ := RandomData;
    MyDD.Add('Item' + IntToStr(I),S);
  end;
  FillListBox;
  UpdateButtons(True);
end;

procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
  LB1.Clear;
  MyDD.Clear;
  Edit1.Clear;
  Edit2.Clear;
end;

procedure TSTDlg.AddBtnClick(Sender: TObject);
var
  Name : ShortString;
  PS   : ^ShortString;
begin
  if (Edit1.Text = '') OR (Edit2.Text = '') then
  begin
    ShowMessage('Name and/or data missing');
    Exit;
  end;

  GetMem(PS,SizeOf(ShortString));
  PS^ := Edit2.Text;
  Name := Edit1.Text;

  MyDD.Add(Name,PS);

  FillListBox;
end;

procedure TSTDlg.UpDateBtnClick(Sender: TObject);
var
  P    : Pointer;
begin
  if (Edit1.Text = '') OR (Edit2.Text = '') then
  begin
    ShowMessage('Name and/or data missing');
    Exit;
  end;

   if (MyDD.Exists(Edit1.Text,P)) then
  begin
    ShortString(P^) := Edit2.Text;
    MyDD.Update(Edit1.Text,P);
  end else
  begin
    ShowMessage(Edit1.Text + ' not found');
    Exit;
  end;
  FillListBox;
end;

procedure TSTDlg.DelBtnClick(Sender: TObject);
var
  P : Pointer;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('No name entered');
    Exit;
  end;

  if (MyDD.Exists(Edit1.Text,P)) then
  begin
    MyDD.Delete(Edit1.Text);
    FillListBox;
  end else
    ShowMessage('Entry not found');
end;

procedure TSTDlg.ExistsBtnClick(Sender: TObject);
var
  S : Pointer;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('No name entry');
    Exit;
  end;

  if MyDD.Exists(Edit1.Text,S) then
  begin
    Edit2.Clear;
    Edit2.Text := ShortString(S^);
    Edit2.Update;
  end else
    ShowMessage('No matching entry found');
end;

procedure TSTDlg.LB1Click(Sender: TObject);
var
  S1,
  S2  : string;
  P,
  Len : integer;
begin
  S1 := LB1.Items[LB1.ItemIndex];
  S2 := S1;
  Len := Length(S1);
  P := pos('=',S1);

  Delete(S1,p-1,Len-p+2);
  Edit1.Text := S1;

  Delete(S2,1,p+1);
  Edit2.Text := S2;
end;

procedure TSTDlg.LB1DblClick(Sender: TObject);
var
  P : Pointer;
begin
  if (MyDD.Exists(Edit1.Text,P)) then
  begin
    MyDD.Delete(Edit1.Text);
    FillListBox;
  end;
  LB1.ItemIndex := 0;
  LB1Click(LB1);
end;

procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
  if (OD1.Execute) then
  begin
    if (NOT Assigned(MyDD)) then
    begin
      UpdateButtons(False);
      MyDD := TStDictionary.Create(GHash);
      MyDD.LoadData := MyLoadData;
      MyDD.StoreData := MyStoreData;
    end;

    MyDD.Clear;
    MyDD.LoadFromFile(OD1.FileName);

    FillListBox;
    UpdateButtons(True);
  end;
end;

procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
  if (SD1.Execute) then
    MyDD.StoreToFile(SD1.FileName);
end;


end.
1	(* *** BEGIN LICENSE BLOCK ***
2	* Version: MPL 1.1
3	*
4	* The contents of this file are subject to the Mozilla Public License Version
5	* 1.1 (the "License"); you may not use this file except in compliance with
6	* the License. You may obtain a copy of the License at
7	* http://www.mozilla.org/MPL/
8	*
9	* Software distributed under the License is distributed on an "AS IS" basis,
10	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11	* for the specific language governing rights and limitations under the
12	* License.
13	*
14	* The Original Code is TurboPower SysTools
15	*
16	* The Initial Developer of the Original Code is
17	* TurboPower Software
18	*
19	* Portions created by the Initial Developer are Copyright (C) 1996-2002
20	* the Initial Developer. All Rights Reserved.
21	*
22	* Contributor(s):
23	*
24	* *** END LICENSE BLOCK *** *)
25
26	unit ExDictU;
27
28	interface
29
30	uses
31	Windows, Messages, SysUtils, Classes, Graphics, Controls,
32	Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,
33
34	StConst, StBase, StUtils, StList, StDict;
35
36	type
37	TSTDlg = class(TForm)
38	CreateBtn: TButton;
39	ClearBtn: TButton;
40	LB1: TListBox;
41	Label9: TLabel;
42	Edit1: TEdit;
43	Label10: TLabel;
44	Edit2: TEdit;
45	AddBtn: TButton;
46	DelBtn: TButton;
47	ExistsBtn: TButton;
48	UpDateBtn: TButton;
49	SaveBtn: TButton;
50	LoadBtn: TButton;
51	OD1: TOpenDialog;
52	SD1: TSaveDialog;
53	Label1: TLabel;
54
55	procedure FormCreate(Sender: TObject);
56	procedure FormClose(Sender: TObject; var Action: TCloseAction);
57
58	procedure ClearBtnClick(Sender: TObject);
59	procedure AddBtnClick(Sender: TObject);
60	procedure DelBtnClick(Sender: TObject);
61	procedure ExistsBtnClick(Sender: TObject);
62	procedure CreateBtnClick(Sender: TObject);
63	procedure UpDateBtnClick(Sender: TObject);
64	procedure LB1Click(Sender: TObject);
65	procedure LB1DblClick(Sender: TObject);
66	procedure LoadBtnClick(Sender: TObject);
67	procedure SaveBtnClick(Sender: TObject);
68
69	private
70	{ Private declarations }
71	public
72	{ Public declarations }
73	MyDD : TStDictionary;
74
75	function RandomData : ShortString;
76	procedure UpdateButtons(DOK : Boolean);
77	procedure FillListBox;
78	end;
79
80	var
81	STDlg: TSTDlg;
82
83	implementation
84
85	{$R *.DFM}
86
87	const
88	MaxElem = 100;
89	MaxLen = 15;
90	GHash = 127;
91
92
93	function DDWalker(Container : TStContainer;
94	Data : TStNode;
95	OtherData : Pointer) : Boolean; far;
96	var
97	S : ShortString;
98	begin
99	S := ShortString(Data.Data^);
100	STDlg.LB1.Items.Add(TStDictNode(Data).Name + ' = ' + S);
101	Result := True;
102	end;
103
104	function MyLoadData(Reader : TReader) : Pointer; far;
105	begin
106	GetMem(Result,SizeOf(ShortString));
107	ShortString(Result^) := Reader.ReadString;
108	end;
109
110	procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
111	begin
112	Writer.WriteString(ShortString(Data^));
113	end;
114
115	procedure TSTDlg.FillListBox;
116	begin
117	LB1.Clear;
118	LB1.Perform(WM_SETREDRAW,0,0);
119
120	MyDD.Iterate(DDWalker,nil);
121
122	LB1.Perform(WM_SETREDRAW,1,0);
123	LB1.Update;
124	end;
125
126	procedure TSTDlg.UpdateButtons(DOK : Boolean);
127	begin
128	ClearBtn.Enabled := DOK;
129	AddBtn.Enabled := DOK;
130	UpdateBtn.Enabled := DOK;
131	ExistsBtn.Enabled := DOK;
132	DelBtn.Enabled := DOK;
133	SaveBtn.Enabled := DOK;
134	LB1.Enabled := DOK;
135	end;
136
137	procedure TSTDlg.FormCreate(Sender: TObject);
138	begin
139	RegisterClasses([TStDictionary,TStDictNode]);
140	UpdateButtons(False);
141	end;
142
143	procedure TSTDlg.FormClose(Sender: TObject;
144	var Action: TCloseAction);
145	begin
146	MyDD.Free;
147	end;
148
149	function TSTDlg.RandomData : ShortString;
150	var
151	Len,
152	I : Integer;
153	begin
154	Len := Random(MaxLen)+1;
155	Result[0] := Chr(Len);
156	for I := 1 to Len do
157	Result[I] := Chr(Random(26) + Ord('A'));
158	end;
159
160	procedure TSTDlg.CreateBtnClick(Sender: TObject);
161	var
162	I : Integer;
163	S : ^ShortString;
164	begin
165	Randomize;
166	if Assigned(MyDD) then
167	MyDD.Free;
168
169	UpdateButtons(False);
170	MyDD := TStDictionary.Create(GHash);
171	MyDD.LoadData := MyLoadData;
172	MyDD.StoreData := MyStoreData;
173	MyDD.Hash := AnsiElfHashText;
174
175	for I := 1 to MaxElem do
176	begin
177	GetMem(S,SizeOf(ShortString));
178	S^ := RandomData;
179	MyDD.Add('Item' + IntToStr(I),S);
180	end;
181	FillListBox;
182	UpdateButtons(True);
183	end;
184
185	procedure TSTDlg.ClearBtnClick(Sender: TObject);
186	begin
187	LB1.Clear;
188	MyDD.Clear;
189	Edit1.Clear;
190	Edit2.Clear;
191	end;
192
193	procedure TSTDlg.AddBtnClick(Sender: TObject);
194	var
195	Name : ShortString;
196	PS : ^ShortString;
197	begin
198	if (Edit1.Text = '') OR (Edit2.Text = '') then
199	begin
200	ShowMessage('Name and/or data missing');
201	Exit;
202	end;
203
204	GetMem(PS,SizeOf(ShortString));
205	PS^ := Edit2.Text;
206	Name := Edit1.Text;
207
208	MyDD.Add(Name,PS);
209
210	FillListBox;
211	end;
212
213	procedure TSTDlg.UpDateBtnClick(Sender: TObject);
214	var
215	P : Pointer;
216	begin
217	if (Edit1.Text = '') OR (Edit2.Text = '') then
218	begin
219	ShowMessage('Name and/or data missing');
220	Exit;
221	end;
222
223	if (MyDD.Exists(Edit1.Text,P)) then
224	begin
225	ShortString(P^) := Edit2.Text;
226	MyDD.Update(Edit1.Text,P);
227	end else
228	begin
229	ShowMessage(Edit1.Text + ' not found');
230	Exit;
231	end;
232	FillListBox;
233	end;
234
235	procedure TSTDlg.DelBtnClick(Sender: TObject);
236	var
237	P : Pointer;
238	begin
239	if (Edit1.Text = '') then
240	begin
241	ShowMessage('No name entered');
242	Exit;
243	end;
244
245	if (MyDD.Exists(Edit1.Text,P)) then
246	begin
247	MyDD.Delete(Edit1.Text);
248	FillListBox;
249	end else
250	ShowMessage('Entry not found');
251	end;
252
253	procedure TSTDlg.ExistsBtnClick(Sender: TObject);
254	var
255	S : Pointer;
256	begin
257	if (Edit1.Text = '') then
258	begin
259	ShowMessage('No name entry');
260	Exit;
261	end;
262
263	if MyDD.Exists(Edit1.Text,S) then
264	begin
265	Edit2.Clear;
266	Edit2.Text := ShortString(S^);
267	Edit2.Update;
268	end else
269	ShowMessage('No matching entry found');
270	end;
271
272	procedure TSTDlg.LB1Click(Sender: TObject);
273	var
274	S1,
275	S2 : string;
276	P,
277	Len : integer;
278	begin
279	S1 := LB1.Items[LB1.ItemIndex];
280	S2 := S1;
281	Len := Length(S1);
282	P := pos('=',S1);
283
284	Delete(S1,p-1,Len-p+2);
285	Edit1.Text := S1;
286
287	Delete(S2,1,p+1);
288	Edit2.Text := S2;
289	end;
290
291	procedure TSTDlg.LB1DblClick(Sender: TObject);
292	var
293	P : Pointer;
294	begin
295	if (MyDD.Exists(Edit1.Text,P)) then
296	begin
297	MyDD.Delete(Edit1.Text);
298	FillListBox;
299	end;
300	LB1.ItemIndex := 0;
301	LB1Click(LB1);
302	end;
303
304	procedure TSTDlg.LoadBtnClick(Sender: TObject);
305	begin
306	if (OD1.Execute) then
307	begin
308	if (NOT Assigned(MyDD)) then
309	begin
310	UpdateButtons(False);
311	MyDD := TStDictionary.Create(GHash);
312	MyDD.LoadData := MyLoadData;
313	MyDD.StoreData := MyStoreData;
314	end;
315
316	MyDD.Clear;
317	MyDD.LoadFromFile(OD1.FileName);
318
319	FillListBox;
320	UpdateButtons(True);
321	end;
322	end;
323
324	procedure TSTDlg.SaveBtnClick(Sender: TObject);
325	begin
326	if (SD1.Execute) then
327	MyDD.StoreToFile(SD1.FileName);
328	end;
329
330
331	end.