examples/Delphi/ExListU.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 ExListU;

interface

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

  StConst, StBase, StUtils, StList;

type
  TSTDlg = class(TForm)
    CreateBtn: TButton;
    ClearBtn: TButton;
    DeleteBtn: TButton;
    HeadBtn: TButton;
    LB1: TListBox;
    Edit1: TEdit;
    AppendBtn: TButton;
    InsertBtn: TButton;
    InsSortedBtn: TButton;
    PlaceBtn: TButton;
    PlaceBeforeBtn: TButton;
    SortBtn: TButton;
    Bevel1: TBevel;
    LoadBtn: TButton;
    SaveBtn: TButton;
    OD1: TOpenDialog;
    SD1: TSaveDialog;

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

    procedure CreateBtnClick(Sender: TObject);
    procedure ClearBtnClick(Sender: TObject);
    procedure DeleteBtnClick(Sender: TObject);
    procedure HeadBtnClick(Sender: TObject);
    procedure AppendBtnClick(Sender: TObject);
    procedure InsertBtnClick(Sender: TObject);
    procedure InsSortedBtnClick(Sender: TObject);
    procedure PlaceBtnClick(Sender: TObject);
    procedure PlaceBeforeBtnClick(Sender: TObject);
    procedure SortBtnClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure SetBusy(B : Boolean);
    procedure FillListBox;
    procedure UpdateButtons(LOK : Boolean);
    procedure CreateList;
  end;

var
  STDlg: TSTDlg;

implementation

{$R *.DFM}

const
  MaxElems = 5000;

type
  S10 = string[10];

var
  MyList : TStList;


function MyCompare(Data1, Data2 : Pointer) : Integer; far;
  {-global function used to sort string items in TStList based classes}
begin
  Result := CompareText(S10(Data1^),S10(Data2^));
end;

function MatchStrings(Container : TStContainer;
                      Node : TStNode;
                      OtherData : Pointer) : Boolean; far;
 {-user defined function to search for strings in a
   TStList based class. Used by the TStList.Iterate method}
begin
  Result := S10(Node.Data^) <> S10(OtherData^);
end;

procedure MyDelNodeData(Data : pointer); far;
 {-procedure to delete data pointer in each node
   during call to TStList.Destroy}
begin
  FreeMem(Data,SizeOf(S10));
end;


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


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

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


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

procedure TSTDlg.SetBusy(B : Boolean);
begin
  if B then
    Screen.Cursor := crHourGlass
  else
    Screen.Cursor := crDefault;
end;

procedure TSTDlg.UpdateButtons(LOK : Boolean);
begin
  ClearBtn.Enabled       := LOK;
  DeleteBtn.Enabled      := LOK;
  HeadBtn.Enabled        := LOK;
  AppendBtn.Enabled      := LOK;
  InsertBtn.Enabled      := LOK;
  InsSortedBtn.Enabled   := LOK;
  PlaceBtn.Enabled       := LOK;
  PlaceBeforeBtn.Enabled := LOK;
  SortBtn.Enabled        := LOK;
  SaveBtn.Enabled        := LOK;
end;

procedure TSTDlg.CreateList;
begin
  UpdateButtons(False);
  MyList := TStList.Create(TStListNode);

  MyList.Compare := MyCompare;
  MyList.DisposeData := MyDelNodeData;
  MyList.LoadData := MyLoadData;
  MyList.StoreData := MyStoreData;
end;


procedure TSTDlg.FillListBox;
var
  PN : TStListNode;

begin
  PN := MyList.Head;

  LB1.Clear;
  LB1.Perform(WM_SETREDRAW,0,0);
  SetBusy(True);

  while (PN <> nil) do
  begin
    LB1.Items.Add(S10(PN.Data^));
    PN := MyList.Next(PN);
  end;

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


procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
  J,
  step : integer;
  S    : ^S10;
begin
  if Assigned(MyList) then
    MyList.Free;

  CreateList;
  Randomize;
  for step := 1 to MaxElems do
  begin
    GetMem(S,SizeOf(S10));
    S^[0] := Chr(10);
    for J := 1 to 10 do
      S^[J] := Chr(random(26) + Ord('A'));
    MyList.Append(S);
  end;
  FillListBox;
  UpdateButtons(True);
end;


procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
  MyList.Clear;
  {confirm list was cleared}
  FillListBox;
end;

procedure TSTDlg.DeleteBtnClick(Sender: TObject);
var
  WhichOne : integer;
  PN : TStListNode;
  S : S10;
begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;

  S := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@S);

  if (PN <> nil) then
  begin
    MyList.Delete(PN);
    FillListBox;
  end;
end;

procedure TSTDlg.HeadBtnClick(Sender: TObject);
var
  WhichOne : integer;
  S        : S10;
  PN       : TStListNode;
begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;

  S := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@S);
  if (PN <> nil) then
  begin
    MyList.MoveToHead(PN);
    FillListBox;
  end;
end;

procedure TSTDlg.AppendBtnClick(Sender: TObject);
var
  S   : ^S10;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  MyList.Append(S);
  FillListBox;
end;

procedure TSTDlg.InsertBtnClick(Sender: TObject);
var
  S : ^S10;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  MyList.Insert(S);
  FillListBox;
end;

procedure TSTDlg.InsSortedBtnClick(Sender: TObject);
var
  S : ^S10;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  MyList.InsertSorted(S);
  FillListBox;
end;

procedure TSTDlg.PlaceBtnClick(Sender: TObject);
var
  WhichOne : integer;
  S        : ^S10;
  PS       : S10;
  PN       : TStListNode;
begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  PS := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@PS);
  if (PN <> nil) then
  begin
    MyList.Place(S,PN);
    FillListBox;
  end;
end;

procedure TSTDlg.PlaceBeforeBtnClick(Sender: TObject);
var
  WhichOne : integer;
  S        : ^S10;
  PS       : S10;
  PN       : TStListNode;

begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  PS := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@PS);
  if (PN <> nil) then
  begin
    MyList.PlaceBefore(S,PN);
    FillListBox;
  end;
end;

procedure TSTDlg.SortBtnClick(Sender: TObject);
begin
  MyList.Sort;
  FillListBox;
end;

procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
  if (OD1.Execute) then
  begin
    if (NOT Assigned(MyList)) then
      CreateList;
    MyList.Clear;
    MyList.LoadFromFile(OD1.FileName);

    FillListBox;
    UpdateButtons(True);
  end;
end;

procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
  if (SD1.Execute) then
    MyList.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 ExListU;
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;
35
36	type
37	TSTDlg = class(TForm)
38	CreateBtn: TButton;
39	ClearBtn: TButton;
40	DeleteBtn: TButton;
41	HeadBtn: TButton;
42	LB1: TListBox;
43	Edit1: TEdit;
44	AppendBtn: TButton;
45	InsertBtn: TButton;
46	InsSortedBtn: TButton;
47	PlaceBtn: TButton;
48	PlaceBeforeBtn: TButton;
49	SortBtn: TButton;
50	Bevel1: TBevel;
51	LoadBtn: TButton;
52	SaveBtn: TButton;
53	OD1: TOpenDialog;
54	SD1: TSaveDialog;
55
56	procedure FormCreate(Sender: TObject);
57	procedure FormClose(Sender: TObject; var Action: TCloseAction);
58
59	procedure CreateBtnClick(Sender: TObject);
60	procedure ClearBtnClick(Sender: TObject);
61	procedure DeleteBtnClick(Sender: TObject);
62	procedure HeadBtnClick(Sender: TObject);
63	procedure AppendBtnClick(Sender: TObject);
64	procedure InsertBtnClick(Sender: TObject);
65	procedure InsSortedBtnClick(Sender: TObject);
66	procedure PlaceBtnClick(Sender: TObject);
67	procedure PlaceBeforeBtnClick(Sender: TObject);
68	procedure SortBtnClick(Sender: TObject);
69	procedure LoadBtnClick(Sender: TObject);
70	procedure SaveBtnClick(Sender: TObject);
71	private
72	{ Private declarations }
73	public
74	{ Public declarations }
75	procedure SetBusy(B : Boolean);
76	procedure FillListBox;
77	procedure UpdateButtons(LOK : Boolean);
78	procedure CreateList;
79	end;
80
81	var
82	STDlg: TSTDlg;
83
84	implementation
85
86	{$R *.DFM}
87
88	const
89	MaxElems = 5000;
90
91	type
92	S10 = string[10];
93
94	var
95	MyList : TStList;
96
97
98	function MyCompare(Data1, Data2 : Pointer) : Integer; far;
99	{-global function used to sort string items in TStList based classes}
100	begin
101	Result := CompareText(S10(Data1^),S10(Data2^));
102	end;
103
104	function MatchStrings(Container : TStContainer;
105	Node : TStNode;
106	OtherData : Pointer) : Boolean; far;
107	{-user defined function to search for strings in a
108	TStList based class. Used by the TStList.Iterate method}
109	begin
110	Result := S10(Node.Data^) <> S10(OtherData^);
111	end;
112
113	procedure MyDelNodeData(Data : pointer); far;
114	{-procedure to delete data pointer in each node
115	during call to TStList.Destroy}
116	begin
117	FreeMem(Data,SizeOf(S10));
118	end;
119
120
121	function MyLoadData(Reader : TReader) : Pointer; far;
122	begin
123	GetMem(Result,SizeOf(S10));
124	S10(Result^) := Reader.ReadString;
125	end;
126
127
128	procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
129	begin
130	Writer.WriteString(S10(Data^));
131	end;
132
133	procedure TSTDlg.FormCreate(Sender: TObject);
134	begin
135	RegisterClasses([TStList,TStListNode]);
136	UpdateButtons(False);
137	end;
138
139
140	procedure TSTDlg.FormClose(Sender: TObject;
141	var Action: TCloseAction);
142	begin
143	MyList.Free;
144	end;
145
146	procedure TSTDlg.SetBusy(B : Boolean);
147	begin
148	if B then
149	Screen.Cursor := crHourGlass
150	else
151	Screen.Cursor := crDefault;
152	end;
153
154	procedure TSTDlg.UpdateButtons(LOK : Boolean);
155	begin
156	ClearBtn.Enabled := LOK;
157	DeleteBtn.Enabled := LOK;
158	HeadBtn.Enabled := LOK;
159	AppendBtn.Enabled := LOK;
160	InsertBtn.Enabled := LOK;
161	InsSortedBtn.Enabled := LOK;
162	PlaceBtn.Enabled := LOK;
163	PlaceBeforeBtn.Enabled := LOK;
164	SortBtn.Enabled := LOK;
165	SaveBtn.Enabled := LOK;
166	end;
167
168	procedure TSTDlg.CreateList;
169	begin
170	UpdateButtons(False);
171	MyList := TStList.Create(TStListNode);
172
173	MyList.Compare := MyCompare;
174	MyList.DisposeData := MyDelNodeData;
175	MyList.LoadData := MyLoadData;
176	MyList.StoreData := MyStoreData;
177	end;
178
179
180	procedure TSTDlg.FillListBox;
181	var
182	PN : TStListNode;
183
184	begin
185	PN := MyList.Head;
186
187	LB1.Clear;
188	LB1.Perform(WM_SETREDRAW,0,0);
189	SetBusy(True);
190
191	while (PN <> nil) do
192	begin
193	LB1.Items.Add(S10(PN.Data^));
194	PN := MyList.Next(PN);
195	end;
196
197	LB1.Perform(WM_SETREDRAW,1,0);
198	LB1.Update;
199	SetBusy(False);
200	end;
201
202
203	procedure TSTDlg.CreateBtnClick(Sender: TObject);
204	var
205	J,
206	step : integer;
207	S : ^S10;
208	begin
209	if Assigned(MyList) then
210	MyList.Free;
211
212	CreateList;
213	Randomize;
214	for step := 1 to MaxElems do
215	begin
216	GetMem(S,SizeOf(S10));
217	S^[0] := Chr(10);
218	for J := 1 to 10 do
219	S^[J] := Chr(random(26) + Ord('A'));
220	MyList.Append(S);
221	end;
222	FillListBox;
223	UpdateButtons(True);
224	end;
225
226
227	procedure TSTDlg.ClearBtnClick(Sender: TObject);
228	begin
229	MyList.Clear;
230	{confirm list was cleared}
231	FillListBox;
232	end;
233
234	procedure TSTDlg.DeleteBtnClick(Sender: TObject);
235	var
236	WhichOne : integer;
237	PN : TStListNode;
238	S : S10;
239	begin
240	WhichOne := LB1.ItemIndex;
241	if (WhichOne < 0) then
242	begin
243	ShowMessage('No item selected');
244	Exit;
245	end;
246
247	S := LB1.Items[WhichOne];
248	PN := MyList.Iterate(MatchStrings,True,@S);
249
250	if (PN <> nil) then
251	begin
252	MyList.Delete(PN);
253	FillListBox;
254	end;
255	end;
256
257	procedure TSTDlg.HeadBtnClick(Sender: TObject);
258	var
259	WhichOne : integer;
260	S : S10;
261	PN : TStListNode;
262	begin
263	WhichOne := LB1.ItemIndex;
264	if (WhichOne < 0) then
265	begin
266	ShowMessage('No item selected');
267	Exit;
268	end;
269
270	S := LB1.Items[WhichOne];
271	PN := MyList.Iterate(MatchStrings,True,@S);
272	if (PN <> nil) then
273	begin
274	MyList.MoveToHead(PN);
275	FillListBox;
276	end;
277	end;
278
279	procedure TSTDlg.AppendBtnClick(Sender: TObject);
280	var
281	S : ^S10;
282	begin
283	if (Edit1.Text = '') then
284	begin
285	ShowMessage('Empty string not allowed');
286	Exit;
287	end;
288	GetMem(S,SizeOf(S10));
289	S^ := Edit1.Text;
290	MyList.Append(S);
291	FillListBox;
292	end;
293
294	procedure TSTDlg.InsertBtnClick(Sender: TObject);
295	var
296	S : ^S10;
297	begin
298	if (Edit1.Text = '') then
299	begin
300	ShowMessage('Empty string not allowed');
301	Exit;
302	end;
303	GetMem(S,SizeOf(S10));
304	S^ := Edit1.Text;
305	MyList.Insert(S);
306	FillListBox;
307	end;
308
309	procedure TSTDlg.InsSortedBtnClick(Sender: TObject);
310	var
311	S : ^S10;
312	begin
313	if (Edit1.Text = '') then
314	begin
315	ShowMessage('Empty string not allowed');
316	Exit;
317	end;
318	GetMem(S,SizeOf(S10));
319	S^ := Edit1.Text;
320	MyList.InsertSorted(S);
321	FillListBox;
322	end;
323
324	procedure TSTDlg.PlaceBtnClick(Sender: TObject);
325	var
326	WhichOne : integer;
327	S : ^S10;
328	PS : S10;
329	PN : TStListNode;
330	begin
331	WhichOne := LB1.ItemIndex;
332	if (WhichOne < 0) then
333	begin
334	ShowMessage('No item selected');
335	Exit;
336	end;
337	if (Edit1.Text = '') then
338	begin
339	ShowMessage('Empty string not allowed');
340	Exit;
341	end;
342	GetMem(S,SizeOf(S10));
343	S^ := Edit1.Text;
344	PS := LB1.Items[WhichOne];
345	PN := MyList.Iterate(MatchStrings,True,@PS);
346	if (PN <> nil) then
347	begin
348	MyList.Place(S,PN);
349	FillListBox;
350	end;
351	end;
352
353	procedure TSTDlg.PlaceBeforeBtnClick(Sender: TObject);
354	var
355	WhichOne : integer;
356	S : ^S10;
357	PS : S10;
358	PN : TStListNode;
359
360	begin
361	WhichOne := LB1.ItemIndex;
362	if (WhichOne < 0) then
363	begin
364	ShowMessage('No item selected');
365	Exit;
366	end;
367	if (Edit1.Text = '') then
368	begin
369	ShowMessage('Empty string not allowed');
370	Exit;
371	end;
372	GetMem(S,SizeOf(S10));
373	S^ := Edit1.Text;
374	PS := LB1.Items[WhichOne];
375	PN := MyList.Iterate(MatchStrings,True,@PS);
376	if (PN <> nil) then
377	begin
378	MyList.PlaceBefore(S,PN);
379	FillListBox;
380	end;
381	end;
382
383	procedure TSTDlg.SortBtnClick(Sender: TObject);
384	begin
385	MyList.Sort;
386	FillListBox;
387	end;
388
389	procedure TSTDlg.LoadBtnClick(Sender: TObject);
390	begin
391	if (OD1.Execute) then
392	begin
393	if (NOT Assigned(MyList)) then
394	CreateList;
395	MyList.Clear;
396	MyList.LoadFromFile(OD1.FileName);
397
398	FillListBox;
399	UpdateButtons(True);
400	end;
401	end;
402
403	procedure TSTDlg.SaveBtnClick(Sender: TObject);
404	begin
405	if (SD1.Execute) then
406	MyList.StoreToFile(SD1.FileName);
407	end;
408
409
410	end.