source: cprs/branches/tmg-cprs/CPRS-Lib/ORClasses.pas@ 1119

Last change on this file since 1119 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

File size: 20.5 KB
Line 
1unit ORClasses;
2
3interface
4
5uses
6 SysUtils, Classes, Controls, ComCtrls, ExtCtrls, StdCtrls, Forms, ORFn;
7
8type
9 TNotifyProc = procedure(Sender: TObject);
10
11 TORNotifyList = class(TObject)
12 private
13 FCode: TList;
14 FData: TList;
15 protected
16 function GetItems(index: integer): TNotifyEvent;
17 procedure SetItems(index: integer; const Value: TNotifyEvent);
18 function GetIsProc(index: integer): boolean;
19 function GetProcs(index: integer): TNotifyProc;
20 procedure SetProcs(index: integer; const Value: TNotifyProc);
21 public
22 constructor Create;
23 destructor Destroy; override;
24 function IndexOf(const NotifyProc: TNotifyEvent): integer; overload;
25 function IndexOf(const NotifyProc: TNotifyProc): integer; overload;
26 procedure Add(const NotifyProc: TNotifyEvent); overload;
27 procedure Add(const NotifyProc: TNotifyProc); overload;
28 procedure Clear;
29 function Count: integer;
30 procedure Delete(index: integer);
31 procedure Remove(const NotifyProc: TNotifyEvent); overload;
32 procedure Remove(const NotifyProc: TNotifyProc); overload;
33 procedure Notify(Sender: TObject);
34 property Items[index: integer]: TNotifyEvent read GetItems write SetItems; default;
35 property Procs[index: integer]: TNotifyProc read GetProcs write SetProcs;
36 property IsProc[index: integer]: boolean read GetIsProc;
37 end;
38
39 TCanNotifyEvent = procedure(Sender: TObject; var CanNotify: boolean) of object;
40
41 IORNotifier = interface(IUnknown)
42 function GetOnNotify: TCanNotifyEvent;
43 procedure SetOnNotify(Value: TCanNotifyEvent);
44 procedure BeginUpdate;
45 procedure EndUpdate(DoNotify: boolean = FALSE);
46 procedure NotifyWhenChanged(Event: TNotifyEvent); overload;
47 procedure NotifyWhenChanged(Event: TNotifyProc); overload;
48 procedure RemoveNotify(Event: TNotifyEvent); overload;
49 procedure RemoveNotify(Event: TNotifyProc); overload;
50 procedure Notify; overload;
51 procedure Notify(Sender: TObject); overload;
52 function NotifyMethod: TNotifyEvent;
53 property OnNotify: TCanNotifyEvent read GetOnNotify Write SetOnNotify;
54 end;
55
56 TORNotifier = class(TInterfacedObject, IORNotifier)
57 private
58 FNotifyList: TORNotifyList;
59 FUpdateCount: integer;
60 FOwner: TObject;
61 FOnNotify: TCanNotifyEvent;
62 protected
63 procedure DoNotify(Sender: TObject);
64 public
65 constructor Create(Owner: TObject = nil; SingleInstance: boolean = FALSE);
66 destructor Destroy; override;
67 function GetOnNotify: TCanNotifyEvent;
68 procedure SetOnNotify(Value: TCanNotifyEvent);
69 procedure BeginUpdate;
70 procedure EndUpdate(DoNotify: boolean = FALSE);
71 procedure NotifyWhenChanged(Event: TNotifyEvent); overload;
72 procedure NotifyWhenChanged(Event: TNotifyProc); overload;
73 procedure RemoveNotify(Event: TNotifyEvent); overload;
74 procedure RemoveNotify(Event: TNotifyProc); overload;
75 procedure Notify; overload;
76 procedure Notify(Sender: TObject); overload;
77 function NotifyMethod: TNotifyEvent;
78 property OnNotify: TCanNotifyEvent read GetOnNotify Write SetOnNotify;
79 end;
80
81 TORStringList = class(TStringList, IORNotifier)
82 private
83 FNotifier: IORNotifier;
84 protected
85 function GetNotifier: IORNotifier;
86 procedure Changed; override;
87 public
88 destructor Destroy; override;
89 procedure KillObjects;
90// IndexOfPiece starts looking at StartIdx+1
91 function CaseInsensitiveIndexOfPiece(Value: string; Delim: Char = '^';
92 PieceNum: integer = 1;
93 StartIdx: integer = -1): integer;
94 function IndexOfPiece(Value: string; Delim: Char = '^';
95 PieceNum: integer = 1;
96 StartIdx: integer = -1): integer;
97 function IndexOfPieces(const Values: array of string; const Delim: Char;
98 const Pieces: array of integer;
99 StartIdx: integer = -1): integer; overload;
100 function IndexOfPieces(const Values: array of string): integer; overload;
101 function IndexOfPieces(const Values: array of string; StartIdx: integer): integer; overload;
102 function PiecesEqual(const Index: integer;
103 const Values: array of string): boolean; overload;
104 function PiecesEqual(const Index: integer;
105 const Values: array of string;
106 const Pieces: array of integer): boolean; overload;
107 function PiecesEqual(const Index: integer;
108 const Values: array of string;
109 const Pieces: array of integer;
110 const Delim: Char): boolean; overload;
111 procedure SetStrPiece(Index, PieceNum: integer; Delim: Char; const NewValue: string); overload;
112 procedure SetStrPiece(Index, PieceNum: integer; const NewValue: string); overload;
113 procedure SortByPiece(PieceNum: integer; Delim: Char = '^');
114 procedure SortByPieces(Pieces: array of integer; Delim: Char = '^');
115 procedure RemoveDuplicates(CaseSensitive: boolean = TRUE);
116 property Notifier: IORNotifier read GetNotifier implements IORNotifier;
117 end;
118
119{ Do NOT add ANTHING to the ORExposed Classes except to change the scope
120 of a property. If you do, existing code could generate Access Violations }
121 TORExposedCustomEdit = class(TCustomEdit)
122 public
123 property ReadOnly;
124 end;
125
126 TORExposedAnimate = class(TAnimate)
127 public
128 property OnMouseUp;
129 property OnMouseDown;
130 end;
131
132 TORExposedControl = class(TControl)
133 public
134 property Font;
135 property Text;
136 end;
137
138{ AddToNotifyWhenCreated allows you to add an event handler before the object that
139 calls that event handler is created. This only works when there is only one
140 instance of a given object created (like TPatient or TEncounter). For an object
141 to make use of this feature, it must call ObjectCreated in the constructor,
142 which will return the TORNotifyList that was created for that object. }
143procedure AddToNotifyWhenCreated(ProcToAdd: TNotifyEvent; CreatedClass: TClass); overload;
144procedure AddToNotifyWhenCreated(ProcToAdd: TNotifyProc; CreatedClass: TClass); overload;
145procedure ObjectCreated(CreatedClass: TClass; var NotifyList: TORNotifyList);
146
147type
148 TORInterfaceList = class(TList)
149 private
150 function GetItem(Index: Integer): IUnknown;
151 procedure SetItem(Index: Integer; const Value: IUnknown);
152 protected
153 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
154 public
155 function Add(Item: IUnknown): Integer;
156 function Extract(Item: IUnknown): IUnknown;
157 function First: IUnknown;
158 function IndexOf(Item: IUnknown): Integer;
159 procedure Insert(Index: Integer; Item: IUnknown);
160 function Last: IUnknown;
161 function Remove(Item: IUnknown): Integer;
162 property Items[Index: Integer]: IUnknown read GetItem write SetItem; default;
163 end;
164
165implementation
166
167var
168 NotifyLists: TStringList = nil;
169
170function IndexOfClass(CreatedClass: TClass): integer;
171begin
172 if(not assigned(NotifyLists)) then
173 NotifyLists := TStringList.Create;
174 Result := NotifyLists.IndexOf(CreatedClass.ClassName);
175 if(Result < 0) then
176 Result := NotifyLists.AddObject(CreatedClass.ClassName, TORNotifyList.Create);
177end;
178
179procedure AddToNotifyWhenCreated(ProcToAdd: TNotifyEvent; CreatedClass: TClass); overload;
180var
181 idx: integer;
182
183begin
184 idx := IndexOfClass(CreatedClass);
185 TORNotifyList(NotifyLists.Objects[idx]).Add(ProcToAdd);
186end;
187
188procedure AddToNotifyWhenCreated(ProcToAdd: TNotifyProc; CreatedClass: TClass); overload;
189var
190 idx: integer;
191
192begin
193 idx := IndexOfClass(CreatedClass);
194 TORNotifyList(NotifyLists.Objects[idx]).Add(ProcToAdd);
195end;
196
197procedure ObjectCreated(CreatedClass: TClass; var NotifyList: TORNotifyList);
198var
199 idx: integer;
200
201begin
202 if(assigned(NotifyLists)) then
203 begin
204 idx := IndexOfClass(CreatedClass);
205 if(idx < 0) then
206 NotifyList := nil
207 else
208 begin
209 NotifyList := (NotifyLists.Objects[idx] as TORNotifyList);
210 NotifyLists.Delete(idx);
211 if(NotifyLists.Count <= 0) then
212 KillObj(@NotifyLists);
213 end;
214 end;
215end;
216
217{ TORNotifyList }
218
219constructor TORNotifyList.Create;
220begin
221 inherited;
222 FCode := TList.Create;
223 FData := TList.Create;
224end;
225
226destructor TORNotifyList.Destroy;
227begin
228 KillObj(@FCode);
229 KillObj(@FData);
230 inherited
231end;
232
233function TORNotifyList.IndexOf(const NotifyProc: TNotifyEvent): integer;
234var
235 m: TMethod;
236
237begin
238 if(assigned(NotifyProc) and (FCode.Count > 0)) then
239 begin
240 m := TMethod(NotifyProc);
241 Result := 0;
242 while((Result < FCode.Count) and ((FCode[Result] <> m.Code) or
243 (FData[Result] <> m.Data))) do inc(Result);
244 if Result >= FCode.Count then Result := -1;
245 end
246 else
247 Result := -1;
248end;
249
250procedure TORNotifyList.Add(const NotifyProc: TNotifyEvent);
251var
252 m: TMethod;
253
254begin
255 if(assigned(NotifyProc) and (IndexOf(NotifyProc) < 0)) then
256 begin
257 m := TMethod(NotifyProc);
258 FCode.Add(m.Code);
259 FData.Add(m.Data);
260 end;
261end;
262
263procedure TORNotifyList.Remove(const NotifyProc: TNotifyEvent);
264var
265 idx: integer;
266
267begin
268 idx := IndexOf(NotifyProc);
269 if(idx >= 0) then
270 begin
271 FCode.Delete(idx);
272 FData.Delete(idx);
273 end;
274end;
275
276function TORNotifyList.GetItems(index: integer): TNotifyEvent;
277begin
278 TMethod(Result).Code := FCode[index];
279 TMethod(Result).Data := FData[index];
280end;
281
282procedure TORNotifyList.SetItems(index: integer; const Value: TNotifyEvent);
283begin
284 FCode[index] := TMethod(Value).Code;
285 FData[index] := TMethod(Value).Data;
286end;
287
288procedure TORNotifyList.Notify(Sender: TObject);
289var
290 i: integer;
291 evnt: TNotifyEvent;
292 proc: TNotifyProc;
293
294begin
295 for i := 0 to FCode.Count-1 do
296 begin
297 if(FData[i] = nil) then
298 begin
299 proc := FCode[i];
300 if(assigned(proc)) then proc(Sender);
301 end
302 else
303 begin
304 TMethod(evnt).Code := FCode[i];
305 TMethod(evnt).Data := FData[i];
306 if(assigned(evnt)) then evnt(Sender);
307 end;
308 end;
309end;
310
311procedure TORNotifyList.Clear;
312begin
313 FCode.Clear;
314 FData.Clear;
315end;
316
317function TORNotifyList.Count: integer;
318begin
319 Result := FCode.Count;
320end;
321
322procedure TORNotifyList.Delete(index: integer);
323begin
324 FCode.Delete(index);
325 FData.Delete(index);
326end;
327
328procedure TORNotifyList.Add(const NotifyProc: TNotifyProc);
329begin
330 if(assigned(NotifyProc) and (IndexOf(NotifyProc) < 0)) then
331 begin
332 FCode.Add(@NotifyProc);
333 FData.Add(nil);
334 end;
335end;
336
337function TORNotifyList.IndexOf(const NotifyProc: TNotifyProc): integer;
338var
339 prt: ^TNotifyProc;
340
341begin
342 prt := @NotifyProc;
343 if(assigned(NotifyProc) and (FCode.Count > 0)) then
344 begin
345 Result := 0;
346 while((Result < FCode.Count) and ((FCode[Result] <> prt) or
347 (FData[Result] <> nil))) do inc(Result);
348 if Result >= FCode.Count then Result := -1;
349 end
350 else
351 Result := -1;
352end;
353
354procedure TORNotifyList.Remove(const NotifyProc: TNotifyProc);
355var
356 idx: integer;
357
358begin
359 idx := IndexOf(NotifyProc);
360 if(idx >= 0) then
361 begin
362 FCode.Delete(idx);
363 FData.Delete(idx);
364 end;
365end;
366
367function TORNotifyList.GetIsProc(index: integer): boolean;
368begin
369 Result := (not assigned(FData[index]));
370end;
371
372function TORNotifyList.GetProcs(index: integer): TNotifyProc;
373begin
374 Result := FCode[index];
375end;
376
377procedure TORNotifyList.SetProcs(index: integer; const Value: TNotifyProc);
378begin
379 FCode[index] := @Value;
380 FData[index] := nil;
381end;
382
383{ TORNotifier }
384
385constructor TORNotifier.Create(Owner: TObject = nil; SingleInstance: boolean = FALSE);
386begin
387 FOwner := Owner;
388 if(assigned(Owner) and SingleInstance) then
389 ObjectCreated(Owner.ClassType, FNotifyList);
390end;
391
392destructor TORNotifier.Destroy;
393begin
394 KillObj(@FNotifyList);
395 inherited;
396end;
397
398procedure TORNotifier.BeginUpdate;
399begin
400 inc(FUpdateCount);
401end;
402
403procedure TORNotifier.EndUpdate(DoNotify: boolean = FALSE);
404begin
405 if(FUpdateCount > 0) then
406 begin
407 dec(FUpdateCount);
408 if(DoNotify and (FUpdateCount = 0)) then Notify(FOwner);
409 end;
410end;
411
412procedure TORNotifier.Notify(Sender: TObject);
413begin
414 if((FUpdateCount = 0) and assigned(FNotifyList) and (FNotifyList.Count > 0)) then
415 DoNotify(Sender);
416end;
417
418procedure TORNotifier.Notify;
419begin
420 if((FUpdateCount = 0) and assigned(FNotifyList) and (FNotifyList.Count > 0)) then
421 DoNotify(FOwner);
422end;
423
424procedure TORNotifier.NotifyWhenChanged(Event: TNotifyEvent);
425begin
426 if(not assigned(FNotifyList)) then
427 FNotifyList := TORNotifyList.Create;
428 FNotifyList.Add(Event);
429end;
430
431procedure TORNotifier.NotifyWhenChanged(Event: TNotifyProc);
432begin
433 if(not assigned(FNotifyList)) then
434 FNotifyList := TORNotifyList.Create;
435 FNotifyList.Add(Event);
436end;
437
438procedure TORNotifier.RemoveNotify(Event: TNotifyEvent);
439begin
440 if(assigned(FNotifyList)) then
441 FNotifyList.Remove(Event);
442end;
443
444procedure TORNotifier.RemoveNotify(Event: TNotifyProc);
445begin
446 if(assigned(FNotifyList)) then
447 FNotifyList.Remove(Event);
448end;
449
450function TORNotifier.NotifyMethod: TNotifyEvent;
451begin
452 Result := Notify;
453end;
454
455function TORNotifier.GetOnNotify: TCanNotifyEvent;
456begin
457 Result := FOnNotify;
458end;
459
460procedure TORNotifier.SetOnNotify(Value: TCanNotifyEvent);
461begin
462 FOnNotify := Value;
463end;
464
465procedure TORNotifier.DoNotify(Sender: TObject);
466var
467 CanNotify: boolean;
468
469begin
470 CanNotify := TRUE;
471 if(assigned(FOnNotify)) then
472 FOnNotify(Sender, CanNotify);
473 if(CanNotify) then
474 FNotifyList.Notify(Sender);
475end;
476
477{ TORStringList }
478
479destructor TORStringList.Destroy;
480begin
481 FNotifier := nil; // Frees instance
482 inherited;
483end;
484
485procedure TORStringList.Changed;
486var
487 OldEvnt: TNotifyEvent;
488
489begin
490{ We redirect the OnChange event handler, rather than calling
491 FNotifyList.Notify directly, because inherited may not call
492 OnChange, and we don't have access to the private variables
493 inherited uses to determine if OnChange should be called }
494
495 if(assigned(FNotifier)) then
496 begin
497 OldEvnt := OnChange;
498 try
499 OnChange := FNotifier.NotifyMethod;
500 inherited; // Conditionally Calls FNotifier.Notify
501 finally
502 OnChange := OldEvnt;
503 end;
504 end;
505 inherited; // Conditionally Calls the old OnChange event handler
506end;
507
508function TORStringList.IndexOfPiece(Value: string; Delim: Char;
509 PieceNum: integer;
510 StartIdx: integer): integer;
511begin
512 Result := StartIdx;
513 inc(Result);
514 while((Result >= 0) and (Result < Count) and
515 (Piece(Strings[Result], Delim, PieceNum) <> Value)) do
516 inc(Result);
517 if(Result < 0) or (Result >= Count) then Result := -1;
518end;
519
520function TORStringList.IndexOfPieces(const Values: array of string; const Delim: Char;
521 const Pieces: array of integer;
522 StartIdx: integer = -1): integer;
523var
524 Done: boolean;
525
526begin
527 Result := StartIdx;
528 repeat
529 inc(Result);
530 if(Result >= 0) and (Result < Count) then
531 Done := PiecesEqual(Result, Values, Pieces, Delim)
532 else
533 Done := TRUE;
534 until(Done);
535 if(Result < 0) or (Result >= Count) then Result := -1;
536end;
537
538function TORStringList.IndexOfPieces(const Values: array of string): integer;
539begin
540 Result := IndexOfPieces(Values, U, [], -1);
541end;
542
543function TORStringList.IndexOfPieces(const Values: array of string;
544 StartIdx: integer): integer;
545begin
546 Result := IndexOfPieces(Values, U, [], StartIdx);
547end;
548
549function TORStringList.GetNotifier: IORNotifier;
550begin
551 if(not assigned(FNotifier)) then
552 FNotifier := TORNotifier.Create(Self);
553 Result := FNotifier;
554end;
555
556procedure TORStringList.KillObjects;
557var
558 i: integer;
559
560begin
561 for i := 0 to Count-1 do
562 begin
563 if(assigned(Objects[i])) then
564 begin
565 Objects[i].Free;
566 Objects[i] := nil;
567 end;
568 end;
569end;
570
571function TORStringList.PiecesEqual(const Index: integer;
572 const Values: array of string): boolean;
573begin
574 Result := PiecesEqual(Index, Values, [], U);
575end;
576
577function TORStringList.PiecesEqual(const Index: integer;
578 const Values: array of string;
579 const Pieces: array of integer): boolean;
580begin
581 Result := PiecesEqual(Index, Values, Pieces, U);
582end;
583
584function TORStringList.PiecesEqual(const Index: integer;
585 const Values: array of string;
586 const Pieces: array of integer;
587 const Delim: Char): boolean;
588var
589 i, cnt, p: integer;
590
591begin
592 cnt := 0;
593 Result := TRUE;
594 for i := low(Values) to high(Values) do
595 begin
596 inc(cnt);
597 if(i >= low(Pieces)) and (i <= high(Pieces)) then
598 p := Pieces[i]
599 else
600 p := cnt;
601 if(Piece(Strings[Index], Delim, p) <> Values[i]) then
602 begin
603 Result := FALSE;
604 break;
605 end;
606 end;
607end;
608
609procedure TORStringList.SortByPiece(PieceNum: integer; Delim: Char = '^');
610begin
611 SortByPieces([PieceNum], Delim);
612end;
613
614procedure TORStringList.RemoveDuplicates(CaseSensitive: boolean = TRUE);
615var
616 i: integer;
617 Kill: boolean;
618
619begin
620 i := 1;
621 while (i < Count) do
622 begin
623 if(CaseSensitive) then
624 Kill := (Strings[i] = Strings[i-1])
625 else
626 Kill := (CompareText(Strings[i],Strings[i-1]) = 0);
627 if(Kill) then
628 Delete(i)
629 else
630 inc(i);
631 end;
632end;
633
634function TORStringList.CaseInsensitiveIndexOfPiece(Value: string; Delim: Char = '^';
635 PieceNum: integer = 1; StartIdx: integer = -1): integer;
636begin
637 Result := StartIdx;
638 inc(Result);
639 while((Result >= 0) and (Result < Count) and
640 (CompareText(Piece(Strings[Result], Delim, PieceNum), Value) <> 0)) do
641 inc(Result);
642 if(Result < 0) or (Result >= Count) then Result := -1;
643end;
644
645procedure TORStringList.SortByPieces(Pieces: array of integer;
646 Delim: Char = '^');
647
648 procedure QSort(L, R: Integer);
649 var
650 I, J: Integer;
651 P: string;
652
653 begin
654 repeat
655 I := L;
656 J := R;
657 P := Strings[(L + R) shr 1];
658 repeat
659 while ComparePieces(Strings[I], P, Pieces, Delim, TRUE) < 0 do Inc(I);
660 while ComparePieces(Strings[J], P, Pieces, Delim, TRUE) > 0 do Dec(J);
661 if I <= J then
662 begin
663 Exchange(I, J);
664 Inc(I);
665 Dec(J);
666 end;
667 until I > J;
668 if L < J then QSort(L, J);
669 L := I;
670 until I >= R;
671 end;
672
673begin
674 if not Sorted and (Count > 1) then
675 begin
676 Changing;
677 QSort(0, Count - 1);
678 Changed;
679 end;
680end;
681
682
683procedure TORStringList.SetStrPiece(Index, PieceNum: integer; Delim: Char;
684 const NewValue: string);
685var
686 tmp: string;
687
688begin
689 tmp := Strings[Index];
690 ORFn.SetPiece(tmp,Delim,PieceNum,NewValue);
691 Strings[Index] := tmp;
692end;
693
694procedure TORStringList.SetStrPiece(Index, PieceNum: integer;
695 const NewValue: string);
696begin
697 SetStrPiece(Index, PieceNum, '^', NewValue);
698end;
699
700{ TORInterfaceList }
701
702function TORInterfaceList.Add(Item: IUnknown): Integer;
703begin
704 Result := inherited Add(Pointer(Item));
705end;
706
707function TORInterfaceList.Extract(Item: IUnknown): IUnknown;
708begin
709 Result := IUnknown(inherited Extract(Pointer(Item)));
710end;
711
712function TORInterfaceList.First: IUnknown;
713begin
714 Result := IUnknown(inherited First);
715end;
716
717function TORInterfaceList.GetItem(Index: Integer): IUnknown;
718begin
719 Result := IUnknown(inherited Get(Index));
720end;
721
722function TORInterfaceList.IndexOf(Item: IUnknown): Integer;
723begin
724 Result := inherited IndexOf(Pointer(Item));
725end;
726
727procedure TORInterfaceList.Insert(Index: Integer; Item: IUnknown);
728begin
729 inherited Insert(Index, Pointer(Item));
730end;
731
732function TORInterfaceList.Last: IUnknown;
733begin
734 Result := IUnknown(inherited Last);
735end;
736
737procedure TORInterfaceList.Notify(Ptr: Pointer; Action: TListNotification);
738begin
739 case Action of
740 lnAdded: IUnknown(Ptr)._AddRef;
741 lnDeleted, lnExtracted: IUnknown(Ptr)._Release;
742 end;
743end;
744
745function TORInterfaceList.Remove(Item: IUnknown): Integer;
746begin
747 Result := inherited Remove(Pointer(Item));
748end;
749
750procedure TORInterfaceList.SetItem(Index: Integer; const Value: IUnknown);
751begin
752 inherited Put(Index, Pointer(Value));
753end;
754
755
756initialization
757
758finalization
759 KillObj(@NotifyLists, TRUE);
760
761end.
Note: See TracBrowser for help on using the repository browser.