source: cprs/trunk/VA/VA508Accessibility/VA508AccessibilityCompiler.pas@ 1696

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

Upgrade to version 27

File size: 33.2 KB
Line 
1unit VA508AccessibilityCompiler;
2
3{$UNDEF VA508COMPILER}
4{$DEFINE VA508COMPILER}
5
6{ TODO -oJeremy Merrill -c508 :
7Add additional warning types:
81) forms in app without 508 manager components
92) hints about default components?
103) components without tab stops, filter out panels that don't have on click events }
11interface
12
13uses
14 SysUtils, DesignIntf, DesignEditors, TypInfo, Controls, StdCtrls, Classes, ToolsApi,
15 Forms, VA508AccessibilityManager, StrUtils, Windows, Variants, Dialogs;
16
17type
18 TVA508Compiler = class(TNotifierObject, IOTANotifier, IOTAIDENotifier, IOTAIDENotifier50, IOTAIDENotifier80)
19 private
20 FErrorCount: integer;
21 FWarningCount: integer;
22 FCached: integer;
23 FBuilt: integer;
24 FDFMDataCount: integer;
25 F508Problems: boolean;
26 FMessageLog: TStringList;
27 F508ManagersFound: boolean;
28 FCompileStopped: boolean;
29 FOpenFiles: TStringList;
30 procedure ScanFor508Errors(const Project: IOTAProject);
31 procedure startMessages;
32 procedure stopMessages;
33 procedure UpdateMonitor(FileName: string);
34 procedure StopCompile;
35 procedure msg(txt: String);
36 procedure infoMessage(fileName, infoText: string);
37 procedure error(fileName, errorText: string);
38 procedure warning(fileName, errorText: string);
39 function CompileNA: boolean;
40 protected
41 procedure AfterCompile(Succeeded: Boolean); overload;
42 procedure AfterCompile(Succeeded: Boolean; IsCodeInsight: Boolean); overload;
43 procedure AfterCompile(const Project: IOTAProject; Succeeded: Boolean; IsCodeInsight: Boolean); overload;
44 procedure BeforeCompile(const Project: IOTAProject; var Cancel: Boolean); overload;
45 procedure BeforeCompile(const Project: IOTAProject; IsCodeInsight: Boolean; var Cancel: Boolean); overload;
46 procedure FileNotification(NotifyCode: TOTAFileNotification; const FileName: string; var Cancel: Boolean);
47 public
48 constructor Create;
49 destructor Destroy; override;
50 end;
51
52procedure Register;
53procedure Unregister;
54procedure DLLUnload(Reason: Integer);
55
56implementation
57
58uses VA508AccessibilityCompileInfo, VAUtils,
59 VA508Classes, VA508AccessibilityPE;
60
61var
62 NotifierIndex: Integer = -1;
63 NotifierRegistered: boolean = false;
64 SaveDllProc: TDLLProc;
65 MessageService: IOTAMessageServices;
66
67const
68 VA508 = 'VA 508 ';
69 MSG_PREFIX = VA508 + 'Compile Scan';
70 VA508_SCAN = MSG_PREFIX + ' ';
71 VA508_SCAN_MESSAGE_START = VA508_SCAN + '...';
72 VA508_SCAN_DONE = VA508_SCAN + 'Complete - ';
73 VA508_ACCURACY_DISCALIMER = ' (scan is not accurate if there are unsaved forms)';
74 VA508_SCAN_PASSED = VA508_SCAN_DONE + 'No Errors or Warnings Found' + VA508_ACCURACY_DISCALIMER;
75 VA508_SCAN_ERROR_COUNT = VA508_SCAN_DONE + '%d Error%s Found'+VA508_ACCURACY_DISCALIMER;
76 VA508_SCAN_WARNING_COUNT = VA508_SCAN_DONE + '%d Warning%s Found'+VA508_ACCURACY_DISCALIMER;
77 VA508_SCAN_WARNINGS_AND_ERRORS_COUNT = VA508_SCAN_DONE + '%d Warning%s, and %d Error%s Found';
78 ERROR_DUPLICATE_COMPONENTS = 'There is more than one %s component on this form';
79 ERROR_READ_ONLY_FILE = 'Compile scan can''t automatically correct error because form files are read only. Please change the read only file status. ';
80 ERROR_CLOSE_FILE_FIRST = 'Compile scan can''t automatically correct error because form %s is currently open in Delphi. Please close the file in Delphi. ';
81 WARNING_NO_508_DATA = '"%s" has no accessibility data';
82 ERROR_INVALID_DFM = 'Form is not a Text DFM or is corrupted';
83 ERROR_CODE = '@\*^ERROR^*/@';
84 ERROR_CODE_LEN = length(ERROR_CODE);
85 WARNING_CODE = '@\*^WARNING^*/@';
86 WARNING_CODE_LEN = length(WARNING_CODE);
87 INFO_ALERT = ' ***** ';
88 INFO_CODE = '@\*^INFO^*/@';
89 INFO_CODE_LEN = length(INFO_CODE);
90
91procedure Register;
92{$IFDEF VA508COMPILER}
93var
94 Services: IOTAServices;
95{$ENDIF}
96begin
97{$IFDEF VA508COMPILER}
98 Services := BorlandIDEServices as IOTAServices;
99 NotifierRegistered := Assigned(Services);
100 if NotifierRegistered and (NotifierIndex = -1) then
101 begin
102 NotifierIndex := Services.AddNotifier(TVA508Compiler.Create);
103 SaveDllProc := DllProc;
104 DllProc := @DLLUnload;
105 end;
106{$ENDIF}
107end;
108
109procedure Unregister;
110var
111 Services: IOTAServices;
112begin
113 if NotifierRegistered and (NotifierIndex <> -1) then
114 begin
115 Services := BorlandIDEServices as IOTAServices;
116 if Assigned(Services) then
117 begin
118 Services.RemoveNotifier(NotifierIndex);
119 NotifierIndex := -1;
120 NotifierRegistered := false;
121 end;
122 DllProc := SaveDllProc;
123 end;
124end;
125
126procedure DLLUnload(Reason: Integer);
127begin
128 SaveDllProc(Reason);
129 if Reason = DLL_PROCESS_DETACH then
130 Unregister;
131end;
132
133{ TVA508CompileEnforcer }
134
135function HaveMessageServices: boolean;
136begin
137 MessageService := (BorlandIDEServices as IOTAMessageServices);
138 Result := assigned(MessageService);
139end;
140
141procedure TVA508Compiler.BeforeCompile(const Project: IOTAProject; IsCodeInsight: Boolean; var Cancel: Boolean);
142
143 function GetPluralStr(count: integer): string;
144 begin
145 if count = 1 then
146 Result := ''
147 else
148 Result := 's';
149 end;
150
151 procedure ShowErrorMessage(msgtxt: string; count: integer);
152 begin
153 if (count > 0) then
154 msg(Format(msgtxt, [count, GetPluralStr(count)]));
155 end;
156
157 procedure Do508Scan;
158 begin
159 startMessages;
160 msg(VA508_SCAN_MESSAGE_START);
161
162 ScanFor508Errors(Project);
163
164 if F508ManagersFound and F508Problems then
165 begin
166 if (FWarningCount>0) and (FErrorCount>0) then
167 msg(Format(VA508_SCAN_WARNINGS_AND_ERRORS_COUNT, [FWarningCount, GetPluralStr(FWarningCount),
168 FErrorCount, GetPluralStr(FErrorCount)]))
169 else
170 begin
171 ShowErrorMessage(VA508_SCAN_WARNING_COUNT, FWarningCount);
172 ShowErrorMessage(VA508_SCAN_ERROR_COUNT, FErrorCount);
173 end;
174
175 if (FErrorCount > 0 ) then
176 begin
177 Cancel := TRUE;
178 stopMessages;
179 end;
180 end
181 else
182 msg(VA508_SCAN_PASSED);
183 end;
184
185
186begin
187 if (not IsCodeInsight) and HaveMessageServices then
188 begin
189 Do508Scan;
190 end;
191end;
192
193
194procedure TVA508Compiler.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
195begin
196end;
197
198
199procedure TVA508Compiler.AfterCompile(Succeeded: Boolean);
200begin
201end;
202
203procedure TVA508Compiler.AfterCompile(Succeeded, IsCodeInsight: Boolean);
204begin
205 if not IsCodeInsight then
206 stopMessages;
207end;
208
209procedure TVA508Compiler.AfterCompile(const Project: IOTAProject; Succeeded,
210 IsCodeInsight: Boolean);
211begin
212 if not IsCodeInsight then
213 stopMessages;
214end;
215
216function TVA508Compiler.CompileNA: boolean;
217begin
218 Result := FCompileStopped or (not F508ManagersFound);
219end;
220
221constructor TVA508Compiler.Create;
222begin
223 FOpenFiles := TStringList.Create;
224 FOpenFiles.Sorted := TRUE;
225 FOpenFiles.Duplicates := dupIgnore;
226end;
227
228destructor TVA508Compiler.Destroy;
229begin
230 FreeAndNil(FOpenFiles);
231 inherited;
232end;
233
234procedure TVA508Compiler.StopCompile;
235begin
236 FCompileStopped := true;
237end;
238
239procedure TVA508Compiler.startMessages;
240begin
241 MessageService.ClearCompilerMessages;
242 if assigned(FMessageLog) then
243 FMessageLog.Clear
244 else
245 FMessageLog := TStringList.Create;
246 FErrorCount := 0;
247 FWarningCount := 0;
248 FCached := 0;
249 FBuilt := 0;
250 F508Problems := false;
251 F508ManagersFound := false;
252 FCompileStopped := false;
253 FDFMDataCount := 0;
254end;
255
256
257procedure TVA508Compiler.stopMessages;
258var
259 i: integer;
260 txt: string;
261 ptr: pointer;
262
263 function MessageOK(text, code: String; codeLen: integer; Kind: TOTAMessageKind): boolean;
264 var
265 p: integer;
266 FileName: string;
267 begin
268 if (copy(text,1,codeLen) = code) then
269 begin
270 Result := FALSE;
271 delete(text,1,codeLen);
272 p := pos(code, text);
273 if (p > 0) then
274 begin
275 FileName := copy(text, 1, p-1);
276 delete(text,1,p + codeLen - 1);
277 MessageService.AddCompilerMessage(FileName, text, MSG_PREFIX, Kind, -1, -1, nil, ptr);
278 //MessageService.AddToolMessage(FileName, text, prefix, 0, 0);
279 end;
280 end
281 else
282 Result := TRUE;
283 end;
284
285begin
286 if CompileNA then exit;
287 if HaveMessageServices and Assigned(FMessageLog) then
288 begin
289 if FMessageLog.Count > 0 then
290 MessageService.ShowMessageView(nil);
291 for i := 0 to FMessageLog.Count-1 do
292 begin
293 txt := FMessageLog[i];
294 if MessageOK(txt, ERROR_CODE, ERROR_CODE_LEN, otamkError) and
295 MessageOK(txt, WARNING_CODE, WARNING_CODE_LEN, otamkWarn) and
296 MessageOK(txt, INFO_CODE, INFO_CODE_LEN, otamkInfo) then
297 MessageService.AddCompilerMessage('', txt, '', otamkInfo, -1, -1, nil, ptr);
298 end;
299 end;
300 if assigned(FMessageLog) then
301 FreeAndNil(FMessageLog);
302end;
303
304procedure TVA508Compiler.UpdateMonitor(FileName: String);
305begin
306 if not FCompileStopped then
307 Update508Monitor(ExtractFileName(FileName), FDFMDataCount, FWarningCount, FErrorCount, FCached, FBuilt, F508ManagersFound);
308end;
309
310procedure TVA508Compiler.error(fileName, errorText: string);
311begin
312 if assigned(FMessageLog) then
313 FMessageLog.add(ERROR_CODE + fileName + ERROR_CODE + errorText);
314 inc(FErrorCount);
315 F508Problems := TRUE;
316 UpdateMonitor(fileName);
317end;
318
319procedure TVA508Compiler.warning(fileName, errorText: string);
320begin
321 if assigned(FMessageLog) then
322 FMessageLog.add(WARNING_CODE + fileName + WARNING_CODE + errorText);
323 inc(FWarningCount);
324 F508Problems := TRUE;
325 UpdateMonitor(fileName);
326end;
327
328procedure TVA508Compiler.msg(txt: String);
329begin
330 if assigned(FMessageLog) then
331 FMessageLog.add(txt);
332end;
333
334procedure TVA508Compiler.FileNotification(
335 NotifyCode: TOTAFileNotification; const FileName: string;
336 var Cancel: Boolean);
337var
338 idx: integer;
339begin
340 if assigned(FOpenFiles) then
341 begin
342 case NotifyCode of
343 ofnFileOpened: FOpenFiles.Add(FileName);
344 ofnFileClosing:
345 begin
346 idx := FOpenFiles.IndexOf(FileName);
347 if idx >= 0 then
348 FOpenFiles.Delete(idx);
349 end;
350 end;
351 end;
352end;
353
354procedure TVA508Compiler.infoMessage(fileName, infoText: string);
355begin
356 if assigned(FMessageLog) then
357 FMessageLog.add(INFO_CODE + fileName + INFO_CODE + INFO_ALERT + infoText);
358 UpdateMonitor(fileName);
359end;
360{
361
362 Data = ()
363
364 inherited mgrMain: TVA508AccessibilityManager
365 Tag = 123
366 OnAccessRequest = mgrMainAccessRequest
367 Left = 16
368 Top = 32
369 Data = (
370 (
371 'Component = Panel1'
372 'Label = Label1'
373 'Status = stsOK')
374 (
375 'Component = Button2'
376 'Property = Caption'
377 'Status = stsOK')
378 (
379 'Component = Memo1'
380 'Status = stsNoData')
381 (
382 'Component = RadioButton1'
383 'Text = Testing'
384 'Status = stsOK')
385 (
386 'Component = Edit1'
387 'Status = stsNoTabStop')
388 (
389 'Component = Form14'
390 'Property = Caption'
391 'Status = stsOK'))
392 end
393}
394// needs alot of work but good enough for now...
395procedure TVA508Compiler.ScanFor508Errors(const Project: IOTAProject);
396const
397 CACHE_EXT = '.VA508';
398 END_OF_INDEX = '|EOINDEX|';
399 OBJ_NAME = 'object ';
400 OBJ_NAME_LEN = length(OBJ_NAME);
401 INHERITED_NAME = 'inherited ';
402 INHERITED_NAME_LEN = length(INHERITED_NAME);
403
404 OBJECT_END = 'end';
405
406 QUOTE = '''';
407 ACCESS_DATA_START_MARKER = '(';
408 ACCESS_DATA_END_MARKER = ')';
409
410 ACCESS_DATA_BEGIN = VA508DFMDataPropertyName + EQU + ACCESS_DATA_START_MARKER;
411 ACCESS_DATA_EMPTY = ACCESS_DATA_BEGIN + ACCESS_DATA_END_MARKER;
412
413 ACCESS_DATA_COMPONENT = QUOTE + AccessDataComponentText + EQU;
414 ACCESS_DATA_COMPONENT_LEN = length(ACCESS_DATA_COMPONENT);
415
416 MAX_PASS_COUNT = 20;
417
418var
419 resourceIndex: integer;
420 dfm: TStringList;
421 tracker: TParentChildFormTracker;
422 lastValidObjectLineWasInherited, lastManagerWasInherited: boolean;
423 lastValidObjectLineClass: string;
424 parser: TVA508Parser;
425 info: IOTAModuleInfo;
426 CurrentFile: string;
427 clsManagerName, ErrorStatusText, lastManagerComponentName: string;
428 ComponentWarnings: TStringList;
429 Working: boolean;
430 PassCount: integer;
431 EmptyManagerList: TStringList;
432 OpenFilesBefore: TStringList;
433 Cache: TStringList;
434 CacheXRef: TStringList;
435 CacheFile: string;
436 CacheModified: boolean;
437 CacheIndex: integer;
438 CacheXRefIndex: integer;
439 CacheSize: integer;
440 CacheValid: boolean;
441
442 Module: IOTAModule;
443 Editor: IOTAEditor;
444
445 procedure IncCacheIndexes(Start, Amount: integer);
446 var
447 i: integer;
448 value: integer;
449 begin
450 i := start;
451 if (i mod 2) <> 0 then
452 inc(i);
453 while i < CacheXRef.Count do
454 begin
455 value := integer(CacheXRef.Objects[i]) + Amount;
456 CacheXRef.Objects[i] := TObject(value);
457 inc(i, 2);
458 end;
459 end;
460
461 procedure SetCacheSize(amount: integer);
462 var
463 diff: integer;
464 begin
465 diff := amount - CacheSize;
466 CacheSize := amount;
467 CacheXRef.Objects[CacheXRefIndex + 1] := TObject(CacheSize);
468 IncCacheIndexes(CacheXRefIndex + 2, diff);
469 CacheModified := TRUE;
470 end;
471
472 procedure Add2Cache(line: string);
473 begin
474 if not CacheValid then
475 begin
476 Cache.Insert(CacheIndex, line);
477 inc(CacheIndex);
478 SetCacheSize(CacheSize + 1);
479 end;
480 end;
481
482 function GetDFMFileName(FileName: string): string;
483 begin
484 Result := copy(FileName,1,Length(FileName)-4) + '.dfm'
485 end;
486
487 function ValidObjectLine(line: String): boolean;
488 var
489 p: integer;
490 begin
491 lastValidObjectLineClass := '';
492 lastValidObjectLineWasInherited := false;
493 result := (LeftStr(line,OBJ_NAME_LEN) = OBJ_NAME);
494 if not result then
495 begin
496 result := (LeftStr(line,INHERITED_NAME_LEN) = INHERITED_NAME);
497 if result then lastValidObjectLineWasInherited := TRUE;
498 end;
499 if result then
500 begin
501 p := pos(':',line);
502 if p>0 then
503 lastValidObjectLineClass := trim(copy(line,p+1,MaxInt));
504 end;
505 end;
506
507 procedure ValidateDFM(var wasDFMValid: boolean; var wasDFMInherited: boolean;
508 var FormClassName: string);
509 begin
510 Add2Cache(dfm[0]);
511 wasDFMValid := ValidObjectLine(dfm[0]);
512 wasDFMInherited := lastValidObjectLineWasInherited;
513 FormClassName := lastValidObjectLineClass;
514 end;
515
516 function GetComponentName(line: string): string;
517 var
518 p,p2: integer;
519 begin
520 Result := '';
521 p := pos(':',line);
522 if p>1 then
523 begin
524 dec(p);
525 p2 := p;
526 while((p>0) and (line[p]<>' ')) do
527 dec(p);
528 Result := trim(copy(line,p+1,p2-p));
529 end;
530 end;
531
532 procedure ClearWarningList(FileName: String);
533 var
534 idx: integer;
535 begin
536 idx := ComponentWarnings.IndexOf(FileName);
537 if idx >= 0 then
538 begin
539 ComponentWarnings.Objects[idx].Free;
540 ComponentWarnings.Delete(idx);
541 end;
542 end;
543
544 function GetWarningList(FileName: String): TStringList;
545 var
546 idx: integer;
547 begin
548 Result := nil;
549 idx := ComponentWarnings.IndexOf(FileName);
550 if idx >= 0 then
551 Result := TStringList(ComponentWarnings.Objects[idx]);
552 end;
553
554 procedure GetManagerInfo(var ManagerCount: integer; var EmptyManager: boolean);
555 var
556 i: integer;
557 InManager, InAccessData, InItem, InError: boolean;
558 line, Component: string;
559 warnings: TStringList;
560
561 begin
562 warnings := GetWarningList(CurrentFile);
563 ManagerCount := 0;
564 EmptyManager := FALSE;
565 InManager := FALSE;
566 InAccessData := FALSE;
567 InItem := FALSE;
568 Component := '';
569 InError := FALSE;
570 i := 0;
571 while i < dfm.count do
572 begin
573 line := trim(dfm[i]);
574 if InManager then
575 begin
576 Add2Cache(line);
577 if InAccessData then
578 begin
579 if InItem then
580 begin
581 if RightStr(line,1) = ACCESS_DATA_END_MARKER then
582 begin
583 InItem := FALSE;
584 delete(line, length(line), 1);
585 end;
586 if RightStr(line,1) = ACCESS_DATA_END_MARKER then
587 begin
588 InAccessData := FALSE;
589 delete(line, length(line), 1);
590 end;
591
592 if LeftStr(line, ACCESS_DATA_COMPONENT_LEN) = ACCESS_DATA_COMPONENT then
593 Component := copy(line, ACCESS_DATA_COMPONENT_LEN + 1,
594 length(line) - ACCESS_DATA_COMPONENT_LEN - 1)
595 else if line = ErrorStatusText then
596 InError := TRUE;
597
598 if (not InItem) and InError and (Component <> '') then
599 begin
600 if not assigned(warnings) then
601 begin
602 warnings := TStringList.Create;
603 ComponentWarnings.AddObject(CurrentFile, warnings);
604 end;
605 warnings.Add(Component);
606 end;
607 end
608 else
609 begin
610 if line = ACCESS_DATA_START_MARKER then
611 begin
612 InItem := TRUE;
613 Component := '';
614 InError := FALSE;
615 end;
616 end;
617 end
618 else
619 begin
620 if line = ACCESS_DATA_BEGIN then
621 begin
622 InAccessData := TRUE;
623 InItem := FALSE;
624 end
625 else
626 if line = ACCESS_DATA_EMPTY then
627 begin
628// if EmptyManagerList.IndexOf(CurrentFile) < 0 then
629 // begin
630 // EmptyManager := TRUE;
631 // EmptyManagerList.Add(CurrentFile);
632 // end;
633 end
634 else
635 if line = OBJECT_END then
636 InManager := FALSE;
637 end;
638 end
639 else
640 if ValidObjectLine(line) then
641 begin
642 if lastValidObjectLineClass = clsManagerName then
643 begin
644 Add2Cache(line);
645 lastManagerComponentName := GetComponentName(dfm[i]);
646 lastManagerWasInherited := lastValidObjectLineWasInherited;
647 inc(ManagerCount);
648 if ManagerCount > 1 then exit;
649 InManager := TRUE;
650 end;
651 end;
652 inc(i);
653 end;
654 end;
655
656 procedure ReportComponentWarnings;
657 var
658 i, j: integer;
659 list: TStringList;
660 fileName: string;
661
662 begin
663 for i := 0 to ComponentWarnings.Count-1 do
664 begin
665 fileName := ComponentWarnings[i];
666 list := TStringList(ComponentWarnings.Objects[i]);
667 for j := 0 to List.Count - 1 do
668 begin
669 warning(fileName, Format(WARNING_NO_508_DATA, [list[j]]));
670 end;
671 end;
672 end;
673
674 procedure InitCache(AFileName: string);
675 var
676 SR: TSearchRec;
677 SRData: string;
678 I: integer;
679
680 begin
681 try
682 if FindFirst(AFileName, faAnyFile, SR) = 0 then
683 begin
684 SRData := IntToStr(SR.Size) + '/' + IntToStr(SR.Time);
685 CacheXRefIndex := CacheXRef.IndexOf(AFileName);
686 if CacheXRefIndex < 0 then
687 begin
688 inc(FBuilt);
689 CacheIndex := Cache.Count;
690 CacheSize := 0;
691 CacheValid := FALSE;
692 CacheXRefIndex := CacheXRef.AddObject(AFileName, TObject(CacheIndex));
693 CacheXRef.AddObject(SRData, TObject(CacheSize));
694 CacheModified := TRUE;
695 end
696 else
697 begin
698 CacheIndex := integer(CacheXRef.Objects[CacheXRefIndex]);
699 CacheSize := integer(CacheXRef.Objects[CacheXRefIndex+1]);
700 CacheValid := (CacheXRef[CacheXRefIndex+1] = SRData);
701 if CacheValid then
702 inc(FCached)
703 else
704 begin
705 inc(FBuilt);
706 CacheXRef[CacheXRefIndex+1] := SRData;
707 for I := 1 to CacheSize do
708 Cache.Delete(CacheIndex);
709 SetCacheSize(0);
710 end;
711 end;
712 UpdateMonitor(AFileName);
713 end;
714 finally
715 SysUtils.FindClose(SR);
716 end;
717 end;
718
719 function FileLoaded(AFileName: string; data: TStringList): boolean;
720 var
721 Temp, I: integer;
722 begin
723 Result := FALSE;
724 try
725 if FileExists(AFileName) then
726 begin
727 InitCache(AFileName);
728 data.Clear;
729 if CacheValid then
730 begin
731 Temp := StrToIntDef(Cache[CacheIndex], 0);
732 inc(FDFMDataCount, Temp);
733 UpdateMonitor(AFileName);
734 Result := TRUE;
735 for I := 1 to CacheSize-1 do
736 data.Add(Cache[CacheIndex+i]);
737 end
738 else
739 begin
740 data.LoadFromFile(AFileName);
741 Result := data.Count > 0;
742 if Result then
743 begin
744 inc(FDFMDataCount, data.Count);
745 Add2Cache(IntToStr(data.Count));
746 UpdateMonitor(AFileName);
747 end;
748 end;
749 end;
750 except
751 end;
752 end;
753
754 function DFMSuccessfullyLoaded: boolean;
755 begin
756 Result := FALSE;
757 if assigned(info) then
758 begin
759 if info.GetModuleType = omtForm then
760 begin
761 CurrentFile := info.FileName;
762 if RightStr(UpperCase(CurrentFile), 4) = '.PAS' then
763 begin
764 Result := FileLoaded(GetDFMFileName(CurrentFile), dfm);
765 end;
766 end;
767 end;
768 end;
769
770 procedure ScanForErrors;
771 var
772 count: integer;
773 wasDFMValid, wasFormInherited, EmptyManager: boolean;
774 formClassName: String;
775 begin
776 lastManagerComponentName := '';
777 formClassName := '';
778 wasDFMValid := FALSE;
779 EmptyManager := false;
780 wasFormInherited := FALSE;
781 lastManagerWasInherited := FALSE;
782 ValidateDFM(wasDFMValid, wasFormInherited, formClassName);
783 if wasDFMValid then
784 begin
785 GetManagerInfo(count, EmptyManager);
786 tracker.AddForm(CurrentFile, formClassName, lastManagerComponentName,
787 EmptyManager, wasFormInherited, lastManagerWasInherited);
788 if count > 0 then
789 F508ManagersFound := true;
790 if count > 1 then
791 begin
792 ClearWarningList(CurrentFile);
793 error(CurrentFile, Format(ERROR_DUPLICATE_COMPONENTS, [clsManagerName]));
794 end;
795 end
796 else
797 error(CurrentFile, ERROR_INVALID_DFM)
798 end;
799
800 procedure ScanFormFiles;
801 var
802 i: integer;
803 begin
804 for i := 0 to Project.GetModuleCount-1 do
805 begin
806 if FCompileStopped then exit;
807 info := Project.GetModule(i);
808 try
809 if DFMSuccessfullyLoaded then
810 ScanForErrors;
811 finally
812 info := nil;
813 end;
814 end;
815 end;
816
817 procedure OpenEditor;
818 begin
819 if assigned(info) and (info.GetModuleType = omtForm) then
820 begin
821 module := info.OpenModule;
822 if assigned(module) then
823 begin
824 Editor := Module.CurrentEditor;
825 end;
826 end;
827 end;
828
829 procedure CloseEditor;
830 begin
831 Editor := nil;
832 try
833 if OpenFilesBefore.IndexOf(CurrentFile) < 0 then
834 begin
835 try
836 module.CloseModule(TRUE);
837 except
838 end;
839 end;
840 finally
841 module := nil;
842 end;
843 end;
844
845 procedure AttemptAutoFix(index: integer; var ErrorText: string);
846 var
847 data: TFormData;
848 code: TParentChildErrorCode;
849 buffer: TStringList;
850 dfmFile, line: string;
851
852 begin
853 code := tracker.ParentChildErrorStatus(index);
854 if not (code in TAutoFixFailCodes) then exit;
855 data := tracker.GetFormData(index);
856 info := Project.FindModuleInfo(data.FileName);
857 if not (assigned(info)) then
858 begin
859 ErrorText := 'Design info not found when attempting autofix. ';
860 exit;
861 end;
862
863 OpenEditor;
864 try
865 if code in [pcNoChildComponent, pcEmptyManagerComponent, pcInheritedNoParent] then
866 begin
867 Editor.MarkModified;
868 Module.Save(FALSE,TRUE);
869 Working := TRUE;
870 if code = pcInheritedNoParent then
871 infoMessage(data.FileName,
872 Format('Form %s has been automatically rebuilt to accommodate deletion of parent %s component', [data.FormClassName, clsManagerName]))
873 else
874 infoMessage(data.FileName,
875 Format('Form %s has been automatically rebuilt to accommodate new %s component', [data.FormClassName, clsManagerName]));
876 end;
877 finally
878 CloseEditor;
879 end;
880 if (ErrorText = '') and (code = pcNoInheritence) then
881 begin
882 dfmFile := GetDFMFileName(data.FileName);
883 try
884 buffer := TStringList.Create;
885 try
886 buffer.LoadFromFile(dfmFile);
887 if (buffer.Count > 0) and (LeftStr(buffer[0], OBJ_NAME_LEN) = OBJ_NAME) then
888 begin
889 line := INHERITED_NAME + copy(buffer[0], OBJ_NAME_LEN + 1, MaxInt);
890 buffer[0] := line;
891 buffer.SaveToFile(dfmFile);
892 Working := TRUE;
893 infoMessage(data.FileName, Format('Form %s has been automatically converted to an inherited form', [data.FormClassName]));
894 end;
895 finally
896 buffer.free;
897 end;
898 except
899 on e: Exception do
900 ErrorText := 'Error ' + e.Message + ' updating DFM File. ';
901 end;
902 end;
903 end;
904
905 {$WARNINGS OFF} // Don't care about platform specific warning
906 function IsFileReadOnly(FileName: string): boolean;
907 begin
908 Result := ((FileGetAttr(FileName) and faReadOnly) <> 0);
909 end;
910 {$WARNINGS ON}
911
912 procedure HandleInheritenceProblems;
913 var
914 i, j, p: integer;
915 data: TFormData;
916 parentClass: string;
917 code: TParentChildErrorCode;
918 ErrorText, BaseError, DFMFile: string;
919 ReadOnly: boolean;
920 DataString: string;
921 DataStrings: TStringList;
922 InStream: TStream;
923 OutStream: TStream;
924
925 begin
926 for i := 0 to tracker.FormCount - 1 do
927 begin
928 if FCompileStopped then exit;
929 data := tracker.GetFormData(i);
930 InitCache(data.FileName);
931 if CacheValid then
932 begin
933 DataString := '';
934 for j := 0 to CacheSize-1 do
935 DataString := DataString + Cache[CacheIndex + j] + #10#13;
936 InStream := TStringStream.Create(DataString);
937 end
938 else
939 InStream := nil;
940 parentClass := parser.GetParentClassName(data.FormClassName, data.FileName, InStream, OutStream);
941 if assigned(OutStream) then
942 begin
943 try
944 if (not CacheValid) then
945 begin
946 p := parser.LastPosition;
947 OutStream.Position := 0;
948 DataStrings := TStringList.Create;
949 try
950 DataString := '';
951 SetLength(DataString, p);
952 OutStream.ReadBuffer(PChar(DataString)^, p);
953 DataStrings.Text := DataString;
954 for j := 0 to DataStrings.Count - 1 do
955 Add2Cache(DataStrings[j]);
956 finally
957 DataStrings.free;
958 end;
959 end;
960 finally
961 OutStream.Free;
962 end;
963 end;
964 inc(FDFMDataCount, parser.LastLineRead);
965 UpdateMonitor(data.FileName);
966 tracker.AddLink(parentClass, data.FormClassName);
967 end;
968 for i := 0 to tracker.FormCount - 1 do
969 begin
970 if FCompileStopped then exit;
971 code := tracker.ParentChildErrorStatus(i);
972 if code in TParentChildFailCodes then
973 begin
974 BaseError := tracker.ParentChildErrorDescription(i);
975 data := tracker.GetFormData(i);
976 ClearWarningList(data.FileName);
977 DFMFile := GetDFMFileName(Data.FileName);
978 ErrorText := '';
979 if code in TAutoFixFailCodes then
980 begin
981 ReadOnly := IsFileReadOnly(DFMFile);
982 if (not ReadOnly) then
983 ReadOnly := IsFileReadOnly(Data.FileName);
984 if ReadOnly then
985 ErrorText := ERROR_READ_ONLY_FILE + BaseError
986 else
987 begin
988 if (FOpenFiles.IndexOf(Data.FileName) >= 0) or
989 (FOpenFiles.IndexOf(DFMFile) >= 0) then
990 ErrorText := Format(ERROR_CLOSE_FILE_FIRST + BaseError, [data.FormClassName])
991 else
992 AttemptAutoFix(i, ErrorText);
993 end;
994 end
995 else
996 ErrorText := BaseError;
997 if ErrorText <> '' then
998 error(DFMFile, ErrorText);
999 end;
1000 end;
1001 end;
1002
1003 procedure CloseModules;
1004 var
1005 i: integer;
1006 begin
1007 for i := 0 to FOpenFiles.Count - 1 do
1008 begin
1009 if OpenFilesBefore.IndexOf(FOpenFiles[i]) < 0 then
1010 begin
1011 info := Project.FindModuleInfo(FOpenFiles[i]);
1012 if assigned(info) then
1013 begin
1014 try
1015 module := info.OpenModule;
1016 if assigned(module) then
1017 begin
1018 try
1019 try
1020 module.CloseModule(TRUE);
1021 except
1022 end;
1023 finally
1024 module := nil;
1025 end;
1026 end;
1027 finally
1028 info := nil;
1029 end;
1030 end;
1031 end;
1032 end;
1033 end;
1034
1035 procedure LoadCacheFile;
1036 var
1037 ProjectName: String;
1038 i,idx,offset, size: integer;
1039
1040 begin
1041 ProjectName := Project.FileName;
1042 CacheFile := Project.ProjectOptions.Values['UnitOutputDir'];
1043 if CacheFile = '' then
1044 CacheFile := ExtractFilePath(ProjectName);
1045 CacheFile := AppendBackSlash(CacheFile);
1046 CacheFile := CacheFile + ExtractFileName(ProjectName);
1047 CacheFile := copy(CacheFile, 1, length(CacheFile) - length(ExtractFileExt(ProjectName))) + CACHE_EXT;
1048 Cache := TStringList.Create;
1049 CacheXRef := TStringList.Create;
1050 if FileExists(CacheFile) then
1051 begin
1052 Cache.LoadFromFile(CacheFile);
1053 idx := Cache.IndexOf(END_OF_INDEX);
1054 if (idx < 0) or ((idx mod 4) <> 0) then
1055 Cache.Clear
1056 else
1057 begin
1058 idx := idx div 4;
1059 for i := 1 to idx do
1060 begin
1061 offset := StrToIntDef(Cache[2], -1);
1062 size := StrToIntDef(Cache[3], -1);
1063 if (offset < 0) or (size < 0) then // bad file.
1064 begin
1065 Cache.Clear;
1066 CacheXRef.Clear;
1067 break;
1068 end;
1069 CacheXRef.addObject(Cache[0], TObject(offset));
1070 CacheXRef.addObject(Cache[1], TObject(size));
1071 Cache.Delete(0);
1072 Cache.Delete(0);
1073 Cache.Delete(0);
1074 Cache.Delete(0);
1075 end;
1076 Cache.Delete(0); // deletes END_OF_INDEX line
1077 end;
1078 end;
1079 CacheModified := FALSE;
1080 end;
1081
1082 procedure SaveCacheFile;
1083 var
1084 CacheIndex, XRefIndex, i: integer;
1085 offset, size: integer;
1086 count: integer;
1087
1088 begin
1089 if CacheModified then
1090 begin
1091 size := Cache.Count + (CacheXRef.Count * 2) + 1;
1092 if Cache.Capacity < size then
1093 Cache.Capacity := size;
1094 Cache.Insert(0, END_OF_INDEX);
1095 CacheIndex := 0;
1096 XRefIndex := 0;
1097 count := CacheXRef.Count div 2;
1098 for i := 0 to count-1 do
1099 begin
1100 offset := Integer(CacheXRef.Objects[XRefIndex]);
1101 Cache.Insert(CacheIndex, CacheXRef[XRefIndex]);
1102 inc(CacheIndex);
1103 inc(XRefIndex);
1104 size := Integer(CacheXRef.Objects[XRefIndex]);
1105 Cache.Insert(CacheIndex, CacheXRef[XRefIndex]);
1106 inc(CacheIndex);
1107 inc(XRefIndex);
1108 Cache.Insert(CacheIndex, IntToStr(offset));
1109 inc(CacheIndex);
1110 Cache.Insert(CacheIndex, IntToStr(size));
1111 inc(CacheIndex);
1112 end;
1113 Cache.SaveToFile(CacheFile);
1114 end;
1115 CacheXRef.Free;
1116 Cache.Free;
1117 end;
1118
1119
1120 procedure CreateResources;
1121 var
1122 i: integer;
1123 begin
1124 Working := TRUE;
1125 PassCount := 0;
1126 resourceIndex := 0;
1127 clsManagerName := TVA508AccessibilityManager.ClassName;
1128 ErrorStatusText := QUOTE + AccessDataStatusText + EQU +
1129 GetEnumName(TypeInfo(TVA508AccessibilityStatus), Ord(stsNoData)) + QUOTE;
1130 info := nil;
1131 Editor := nil;
1132 module := nil;
1133 for i := 1 to 6 do
1134 begin
1135 case i of
1136 1: StartMonitor(Project.FileName, StopCompile);
1137 2: begin
1138 dfm := TStringList.Create;
1139 ComponentWarnings := TStringList.Create;
1140 EmptyManagerList := TStringList.Create;
1141 OpenFilesBefore := TStringList.Create;
1142 end;
1143 3: parser := TVA508Parser.Create;
1144 4: tracker := TParentChildFormTracker.Create;
1145 5: OpenFilesBefore.AddStrings(FOpenFiles);
1146 6: LoadCacheFile;
1147 end;
1148 resourceIndex := i;
1149 end;
1150 end;
1151
1152 procedure DestroyResources;
1153 var
1154 i: integer;
1155 begin
1156 for i := resourceIndex downto 1 do
1157 begin
1158 try
1159 case i of
1160 6: SaveCacheFile;
1161 5: CloseModules;
1162 4: tracker.Free;
1163 3: parser.Free;
1164 2: begin
1165 OpenFilesBefore.Free;
1166 EmptyManagerList.Free;
1167 ComponentWarnings.Free;
1168 dfm.free;
1169 end;
1170 1: StopMonitor;
1171 end;
1172 except
1173 end;
1174 end;
1175 end;
1176
1177 procedure Init;
1178 var
1179 i: integer;
1180 begin
1181 for I := 0 to ComponentWarnings.Count - 1 do
1182 ComponentWarnings.Objects[i].Free;
1183 ComponentWarnings.Clear;
1184 tracker.Clear;
1185 Working := FALSE;
1186 inc(PassCount);
1187 end;
1188
1189begin
1190 try
1191 CreateResources;
1192 while Working and (passCount < MAX_PASS_COUNT) do
1193 begin
1194 Init;
1195 ScanFormFiles;
1196 if not CompileNA then
1197 HandleInheritenceProblems;
1198 end;
1199 if not CompileNA then
1200 ReportComponentWarnings;
1201 finally
1202
1203 DestroyResources;
1204 end;
1205end;
1206initialization
1207
1208finalization
1209 Unregister;
1210
1211end.
1212
Note: See TracBrowser for help on using the repository browser.