source: cprs/trunk/VA/VA508Accessibility/VA508Classes.pas@ 1780

Last change on this file since 1780 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 17.3 KB
Line 
1unit VA508Classes;
2
3interface
4 uses SysUtils, Classes, Contnrs, StrUtils, Windows, HRParser, HRParserPas, Forms, Dialogs;
5
6type
7 TFormData = class
8 private
9 FFileName: string;
10 FlcFormClassName: string;
11 FInheritedForm: boolean;
12 FParent: TFormData;
13 FManagerComponentName: string;
14 FInheritedManager: boolean;
15 FFormClassName: string;
16 FEmptyManager: boolean;
17 procedure SetFormClassName(const Value: string);
18 public
19 function HasManager: boolean;
20 function HasParent: boolean;
21 property FormClassName: string read FFormClassName write SetFormClassName;
22 property lcFormClassName: string read FlcFormClassName;
23 property EmptyManager: boolean read FEmptyManager write FEmptyManager;
24 property FileName: string read FFileName write FFileName;
25 property Parent: TFormData read FParent write FParent;
26 property InheritedForm: boolean read FInheritedForm write FInheritedForm;
27 property InheritedManager: boolean read FInheritedManager write FInheritedManager;
28 property ManagerComponentName: string read FManagerComponentName write FManagerComponentName;
29 end;
30
31 EVA508AccessibilityException = class(Exception);
32
33 TParentChildErrorCode = (pcNoParentManager, pcValidRelationship,
34 pcNoInheritence, pcNoChildComponent, pcEmptyManagerComponent,
35 pcOtherChildComponent, pcInheritedNoParent);
36const
37 TParentChildPassCodes = [pcNoParentManager, pcValidRelationship];
38 TParentChildFailCodes = [pcNoInheritence, pcNoChildComponent, pcEmptyManagerComponent,
39 pcOtherChildComponent, pcInheritedNoParent];
40 TAutoFixFailCodes = [pcNoInheritence, pcEmptyManagerComponent, pcNoChildComponent, pcInheritedNoParent];
41
42type
43 TParentChildFormTracker = class
44 private
45 FData: TObjectList;
46 function FindForm(AFormClassName: String): TFormData;
47 public
48 constructor Create;
49 destructor Destroy; override;
50 procedure Clear;
51 procedure AddForm(AFileName, AFormClassName, AManagerComponentName: string;
52 AEmptyManager: boolean; AInheritedForm, AInheritedManager: boolean);
53 procedure AddLink(ParentFormClassName, ChildFormClassName: string);
54 function FormCount: integer;
55 function GetFormData(index: integer): TFormData;
56 function ParentChildErrorStatus(index: integer): TParentChildErrorCode;
57 function ParentChildErrorDescription(index: integer): string;
58 end;
59
60 TUnitSection = (usUnknown, usInterface, usImplementation);
61 TTokenState = (tsNormal, tsPendingEqualChar, tsPendingClassSymbol, tsPendingParenChar,
62 tsPendingClassName, tsPendingEndOfClass);
63
64 TVA508Parser = class
65 private
66 FClassName: String;
67 FParentClass: String;
68 FPendingParentClass: string;
69 FParser: THRParserPas;
70 FToken: THRToken;
71 FLastLine: integer;
72 FLastPos: integer;
73 FTokenName: String;
74 FState: TTokenState;
75 FUnitSection: TUnitSection;
76 FDone: boolean;
77 FIsSymbol: boolean;
78 FIsChar: boolean;
79 procedure ParseToken;
80 public
81 function GetParentClassName(ClassName, FileName: String;
82 InStream: TStream; var OutStream: TStream): String;
83 function LastLineRead: integer;
84 function LastPosition: integer;
85 end;
86
87procedure VA508ComponentCreationCheck(AComponent, AOwner: TComponent;
88 AllowDataModules: boolean; ManagerRequired: boolean);
89procedure VA508ComponentDestructionCheck(AComponent: TComponent);
90
91const
92 NO_OWNER_ERROR = 'Cannot create a %s component without an owner';
93
94implementation
95
96uses
97 VA508AccessibilityManager, VA508ImageListLabeler;
98
99const
100 MANAGER_CLASS_REQUIRED = 'Cannot create a %s component without a ' + #13#10 +
101 '%s component on the same form';
102 OTHER_COMPONENTS_DELETED = 'Deleting this %s component also deletes all' + #13#10 +
103 'A %s components on this form';
104 OWNER_NOT_ALLOWED = 'You may not place a %s component on a %s';
105 OWNER_REQUIREMENTS = '%s component can only be added to a %s';
106 HAS_EXISTING_MANAGER_ERROR = '%s alread has a %s component';
107
108function HasAnotherAccessibilityManager(Root, AComponent: TComponent): boolean;
109var
110 i: integer;
111 comp: TComponent;
112begin
113 Result := false;
114 for i := 0 to AComponent.ComponentCount-1 do
115 begin
116 comp := AComponent.Components[i];
117 if (comp <> Root) and (comp is TVA508AccessibilityManager) then
118 begin
119 Result := true;
120 exit;
121 end;
122 if HasAnotherAccessibilityManager(Root, AComponent.Components[i]) then
123 begin
124 Result := true;
125 exit;
126 end;
127 end;
128end;
129
130procedure VA508ComponentCreationCheck(AComponent, AOwner: TComponent;
131 AllowDataModules: boolean; ManagerRequired: boolean);
132var
133 msg: string;
134
135 procedure EnsureManager;
136 var
137 i: integer;
138 error: boolean;
139 begin
140 if (csDesigning in AOwner.ComponentState) and (not (csLoading in AOwner.ComponentState)) then
141 begin
142 error := TRUE;
143 for i := 0 to AOwner.ComponentCount-1 do
144 begin
145 if AOwner.Components[i] is TVA508AccessibilityManager then
146 begin
147 error := FALSE;
148 break;
149 end;
150 end;
151 if error then
152 begin
153 raise EVA508AccessibilityException.CreateFmt(MANAGER_CLASS_REQUIRED,
154 [AComponent.ClassName, TVA508AccessibilityManager.ClassName]);
155 end;
156 end;
157 end;
158
159begin
160 if not assigned(AOwner) then
161 raise EVA508AccessibilityException.CreateFmt(NO_OWNER_ERROR, [AComponent.ClassName]);
162 if (AOwner is TDataModule) then
163 begin
164 if AllowDataModules then
165 exit
166 else
167 raise EVA508AccessibilityException.CreateFmt(OWNER_NOT_ALLOWED, [AComponent.ClassName, TDataModule.ClassName]);
168 end;
169 if not (AOwner is TCustomForm) then
170 begin
171 msg := 'Form';
172 if AllowDataModules then
173 msg := msg + ' or a Data Module';
174 raise EVA508AccessibilityException.CreateFmt(OWNER_REQUIREMENTS, [AComponent.ClassName, msg]);
175 end;
176 if ManagerRequired then
177 EnsureManager
178 else
179 begin
180 if HasAnotherAccessibilityManager(AComponent, AOwner) then
181 raise EVA508AccessibilityException.Create(Format(HAS_EXISTING_MANAGER_ERROR,
182 [AOwner.ClassName, AComponent.ClassName]));
183 end;
184end;
185
186procedure VA508ComponentDestructionCheck(AComponent: TComponent);
187var
188 i: integer;
189 list: TObjectList;
190 msg: string;
191 ComponentAccessFound, ImageListLabelerFound: boolean;
192 Owner: TComponent;
193
194begin
195 if not assigned(AComponent) then exit;
196 Owner := AComponent.Owner;
197 if not assigned(Owner) then exit;
198 if HasAnotherAccessibilityManager(AComponent, Owner) then exit;
199 if (csDesigning in AComponent.ComponentState) and (not (csDestroying in Owner.ComponentState)) then
200 begin
201 list := TObjectList.Create;
202 try
203 ComponentAccessFound := FALSE;
204 ImageListLabelerFound := FALSE;
205 for I := 0 to Owner.ComponentCount-1 do
206 begin
207 if Owner.Components[i] is TVA508ComponentAccessibility then
208 begin
209 ComponentAccessFound := TRUE;
210 list.Add(Owner.Components[i]);
211 end
212 else
213 if Owner.Components[i] is TVA508ImageListLabeler then
214 begin
215 ImageListLabelerFound := TRUE;
216 list.Add(Owner.Components[i]);
217 end
218 end;
219 msg := '';
220 if ImageListLabelerFound then
221 msg := TVA508ImageListLabeler.ClassName;
222 if ComponentAccessFound then
223 begin
224 if msg <> '' then
225 msg := msg + ' and ';
226 msg := msg + TVA508ComponentAccessibility.ClassName;
227 end;
228 if msg <> '' then
229 begin
230 MessageDlg(Format(OTHER_COMPONENTS_DELETED, [AComponent.ClassName, msg]), mtWarning, [mbOK], 0);
231 end;
232 finally
233 list.Free;
234 end;
235 end;
236end;
237
238{ TFormData }
239
240function TFormData.HasManager: boolean;
241begin
242 Result := ManagerComponentName <> '';
243end;
244
245function TFormData.HasParent: boolean;
246begin
247 Result := assigned(Parent);
248end;
249
250procedure TFormData.SetFormClassName(const Value: string);
251begin
252 FFormClassName := Value;
253 FlcFormClassName := lowerCase(Value);
254end;
255
256{ TParentChildFormTracker }
257
258procedure TParentChildFormTracker.AddForm(AFileName, AFormClassName, AManagerComponentName: string;
259 AEmptyManager: boolean; AInheritedForm, AInheritedManager: boolean);
260var
261 data: TFormData;
262begin
263 if FindForm(AFormClassName) = nil then
264 begin
265 Data := TFormData.Create;
266 data.FileName := AFileName;
267 data.FormClassName := AFormClassName;
268 data.ManagerComponentName := AManagerComponentName;
269 data.Parent := nil;
270 data.InheritedForm := AInheritedForm;
271 data.InheritedManager := AInheritedManager;
272 data.EmptyManager := AEmptyManager;
273 FData.Add(data);
274 end;
275end;
276
277procedure TParentChildFormTracker.AddLink(ParentFormClassName, ChildFormClassName: string);
278var
279 child,parent: TFormData;
280begin
281 child := FindForm(ChildFormClassName);
282 parent := FindForm(ParentFormClassName);
283 if assigned(child) and assigned(parent) then
284 child.Parent := parent;
285end;
286
287procedure TParentChildFormTracker.Clear;
288begin
289 FData.Clear;
290end;
291
292constructor TParentChildFormTracker.Create;
293begin
294 FData := TObjectList.Create;
295end;
296
297destructor TParentChildFormTracker.Destroy;
298begin
299 FData.Free;
300 inherited;
301end;
302
303function TParentChildFormTracker.FindForm(AFormClassName: String): TFormData;
304var
305 i: integer;
306 name: string;
307begin
308 name := lowercase(AFormClassName);
309 Result := nil;
310 for i := 0 to FData.Count - 1 do
311 begin
312 if GetFormData(i).lcFormClassName = Name then
313 begin
314 Result := GetFormData(i);
315 exit;
316 end;
317 end;
318end;
319
320function TParentChildFormTracker.FormCount: integer;
321begin
322 Result := FData.Count;
323end;
324
325function TParentChildFormTracker.GetFormData(index: integer): TFormData;
326begin
327 Result := TFormData(FData[index]);
328end;
329
330function TParentChildFormTracker.ParentChildErrorDescription(index: integer): string;
331var
332 code: TParentChildErrorCode;
333 parent: TFormData;
334 child: TFormData;
335begin
336 code := ParentChildErrorStatus(index);
337 Result := '';
338 if code in [pcNoParentManager, pcValidRelationship] then exit;
339 child := GetFormData(index);
340 parent := child.Parent;
341 case code of
342 pcNoInheritence: Result := 'Form ' + child.FormClassName + ' descends from form ' + parent.FormClassName +
343 ' but uses the word "object" instead of "inherited" in the .dfm file.';
344 pcNoChildComponent, pcEmptyManagerComponent: Result := 'Form ' + child.FormClassName +
345 ' .dfm file needs to be rebuilt. To fix manually, view the form as text, then as a form, ' +
346 ' make sure the form is in a modified state, and save it.';
347 pcOtherChildComponent: Result := 'Form ' + child.FormClassName + ' has two ' + TVA508AccessibilityManager.ClassName +
348 ' components, one from an inherited form, and one on the form.' +
349 ' Remove the component on the form and use the inherited component';
350 pcInheritedNoParent: Result := 'Form ' + child.FormClassName + ' has a ' + TVA508AccessibilityManager.ClassName +
351 ' component, ' + child.ManagerComponentName +
352 ', that was inherited from a parent form, but ' + child.ManagerComponentName +
353 ' has been deleted from the parent form. To Remove the component, view the form as text, then as a form, ' +
354 ' make sure the form is in a modified state, and save it. Or you can add the ' +
355 TVA508AccessibilityManager.ClassName + ' component back onto the parent form.';
356 else Result := '';
357 end;
358end;
359
360function TParentChildFormTracker.ParentChildErrorStatus(
361 index: integer): TParentChildErrorCode;
362var
363 parent: TFormData;
364 child: TFormData;
365 bad: boolean;
366
367begin
368 Result := pcNoParentManager;
369 child := GetFormData(index);
370 if not assigned(child) then exit;
371
372 bad := false;
373 if child.InheritedManager then
374 begin
375 bad := not child.HasParent;
376 if not bad then
377 bad := not child.InheritedForm;
378 if not bad then
379 bad := not child.Parent.HasManager;
380 end;
381
382 try
383 if not child.HasParent then exit;
384 parent := child.Parent;
385 if not parent.HasManager then exit;
386 if child.InheritedForm then
387 begin
388 if child.HasManager then
389 begin
390 if (parent.ManagerComponentName = child.ManagerComponentName) and
391 (child.InheritedManager) then
392 begin
393 if child.EmptyManager then
394 Result := pcEmptyManagerComponent
395 else
396 Result := pcValidRelationship
397 end
398 else
399 Result := pcOtherChildComponent
400 end
401 else
402 Result := pcNoChildComponent;
403 end
404 else
405 Result := pcNoInheritence;
406 finally
407 if bad and (Result = pcNoParentManager) then
408 Result := pcInheritedNoParent;
409 end;
410end;
411
412const
413 INTERFACE_NAME = 'interface';
414 IMPLEMENTATION_NAME = 'implementation';
415
416 CLASS_NAME = 'class';
417 LEFT_PAREN = '(';
418 RIGHT_PAREN = ')';
419 COMMA = ',';
420 EQUALS = '=';
421
422{ TVA508Parser }
423
424function TVA508Parser.GetParentClassName(ClassName, FileName: String;
425 InStream: TStream; var OutStream: TStream): String;
426begin
427 FClassName := lowerCase(ClassName);
428 FParentClass := '';
429 FState := tsNormal;
430 FUnitSection := usUnknown;
431 FDone := false;
432
433 if(assigned(FParser)) then
434 FParser.Free;
435 FParser := THRParserPas.Create;
436 FLastLine := 0;
437 FLastPos := 0;
438 if assigned(InStream) then
439 FParser.Source := InStream
440 else
441 FParser.Source := TFileStream.Create(FileName, fmOpenRead, fmShareDenyNone);
442 try
443 while (not FDone) and (FParser.NextToken.TokenType <> HR_TOKEN_EOF) do
444 begin
445 FToken := FParser.Token;
446 FLastLine := FToken.Line;
447 FLastPos := FToken.SourcePos;
448 ParseToken;
449 end;
450 finally
451 if assigned(InStream) then
452 begin
453 InStream.Free;
454 OutStream := nil;
455 end
456 else
457 OutStream := FParser.Source;
458 FreeAndNil(FParser);
459 end;
460 Result := FParentClass;
461end;
462
463function TVA508Parser.LastLineRead: integer;
464begin
465 Result := FLastLine;
466end;
467
468function TVA508Parser.LastPosition: integer;
469begin
470 Result := FLastPos + 1;
471end;
472
473procedure TVA508Parser.ParseToken;
474
475 function IgnoreToken: boolean;
476 begin
477 if(FUnitSection = usImplementation) then
478 begin
479 Result := TRUE;
480 exit;
481 end;
482 case FToken.TokenType of
483 HR_TOKEN_TEXT_SPACE, HR_TOKEN_PAS_COMMENT_SLASH,
484 HR_TOKEN_PAS_COMMENT_BRACE_OPEN, HR_TOKEN_PAS_COMMENT_BRACE,
485 HR_TOKEN_PAS_COMMENT_BRACKET_OPEN, HR_TOKEN_PAS_COMMENT_BRACKET:
486 Result := TRUE;
487 else
488 Result := FALSE;
489 end;
490 end;
491
492 function InvalidSection: boolean;
493 var
494 changed: boolean;
495 begin
496 changed := false;
497 if FIsSymbol then
498 begin
499 if FTokenName = INTERFACE_NAME then
500 begin
501 FUnitSection := usInterface;
502 changed := true;
503 end
504 else if FTokenName = IMPLEMENTATION_NAME then
505 begin
506 FUnitSection := usImplementation;
507 FDone := TRUE;
508 changed := true;
509 end;
510 end;
511 Result := (FUnitSection <> usInterface);
512 if changed then
513 FState := tsNormal;
514 end;
515
516begin
517 if(IgnoreToken) then exit;
518
519 FTokenName := LowerCase(FToken.Token);
520 FIsSymbol := (FToken.TokenType = HR_TOKEN_TEXT_SYMBOL);
521 FIsChar := (FToken.TokenType = HR_TOKEN_CHAR);
522
523 if(InvalidSection) then exit;
524 case FState of
525 tsNormal: if FIsSymbol and (FTokenName = FClassName) then
526 FState := tsPendingEqualChar;
527 tsPendingEqualChar: if FIsChar and (FTokenName = EQUALS) then
528 FState := tsPendingClassSymbol
529 else
530 FState := tsNormal;
531 tsPendingClassSymbol: if FIsSymbol and (FTokenName = CLASS_NAME) then
532 FState := tsPendingParenChar
533 else
534 FState := tsNormal;
535 tsPendingParenChar: if FIsChar and (FTokenName = LEFT_PAREN) then
536 FState := tsPendingClassName
537 else
538 FState := tsNormal;
539 tsPendingClassName: if FIsSymbol then
540 begin
541 FPendingParentClass := FToken.Token;
542 FState := tsPendingEndOfClass;
543 end
544 else
545 FState := tsNormal;
546 tsPendingEndOfClass: begin
547 if FIsChar and ((FTokenName = RIGHT_PAREN) or
548 (FTokenName = COMMA)) then
549 begin
550 FParentClass := FPendingParentClass;
551 FDone := TRUE;
552 end;
553 FState := tsNormal;
554 end;
555 else
556 FState := tsNormal;
557 end;
558end;
559
560
561end.
Note: See TracBrowser for help on using the repository browser.