Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

VA508AccessibilityCompiler.pas@ 1094

Last change on this file since 1094 was 829, checked in by Kevin Toppenberg, 14 years ago
Upgrade to version 27
File size: 33.2 KB

Line
1	unit VA508AccessibilityCompiler;
2
3	{$UNDEF VA508COMPILER}
4	{$DEFINE VA508COMPILER}
5
6	{ TODO -oJeremy Merrill -c508 :
7	Add additional warning types:
8	1) forms in app without 508 manager components
9	2) hints about default components?
10	3) components without tab stops, filter out panels that don't have on click events }
11	interface
12
13	uses
14	SysUtils, DesignIntf, DesignEditors, TypInfo, Controls, StdCtrls, Classes, ToolsApi,
15	Forms, VA508AccessibilityManager, StrUtils, Windows, Variants, Dialogs;
16
17	type
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
52	procedure Register;
53	procedure Unregister;
54	procedure DLLUnload(Reason: Integer);
55
56	implementation
57
58	uses VA508AccessibilityCompileInfo, VAUtils,
59	VA508Classes, VA508AccessibilityPE;
60
61	var
62	NotifierIndex: Integer = -1;
63	NotifierRegistered: boolean = false;
64	SaveDllProc: TDLLProc;
65	MessageService: IOTAMessageServices;
66
67	const
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
91	procedure Register;
92	{$IFDEF VA508COMPILER}
93	var
94	Services: IOTAServices;
95	{$ENDIF}
96	begin
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}
107	end;
108
109	procedure Unregister;
110	var
111	Services: IOTAServices;
112	begin
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;
124	end;
125
126	procedure DLLUnload(Reason: Integer);
127	begin
128	SaveDllProc(Reason);
129	if Reason = DLL_PROCESS_DETACH then
130	Unregister;
131	end;
132
133	{ TVA508CompileEnforcer }
134
135	function HaveMessageServices: boolean;
136	begin
137	MessageService := (BorlandIDEServices as IOTAMessageServices);
138	Result := assigned(MessageService);
139	end;
140
141	procedure 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
186	begin
187	if (not IsCodeInsight) and HaveMessageServices then
188	begin
189	Do508Scan;
190	end;
191	end;
192
193
194	procedure TVA508Compiler.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
195	begin
196	end;
197
198
199	procedure TVA508Compiler.AfterCompile(Succeeded: Boolean);
200	begin
201	end;
202
203	procedure TVA508Compiler.AfterCompile(Succeeded, IsCodeInsight: Boolean);
204	begin
205	if not IsCodeInsight then
206	stopMessages;
207	end;
208
209	procedure TVA508Compiler.AfterCompile(const Project: IOTAProject; Succeeded,
210	IsCodeInsight: Boolean);
211	begin
212	if not IsCodeInsight then
213	stopMessages;
214	end;
215
216	function TVA508Compiler.CompileNA: boolean;
217	begin
218	Result := FCompileStopped or (not F508ManagersFound);
219	end;
220
221	constructor TVA508Compiler.Create;
222	begin
223	FOpenFiles := TStringList.Create;
224	FOpenFiles.Sorted := TRUE;
225	FOpenFiles.Duplicates := dupIgnore;
226	end;
227
228	destructor TVA508Compiler.Destroy;
229	begin
230	FreeAndNil(FOpenFiles);
231	inherited;
232	end;
233
234	procedure TVA508Compiler.StopCompile;
235	begin
236	FCompileStopped := true;
237	end;
238
239	procedure TVA508Compiler.startMessages;
240	begin
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;
254	end;
255
256
257	procedure TVA508Compiler.stopMessages;
258	var
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
285	begin
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);
302	end;
303
304	procedure TVA508Compiler.UpdateMonitor(FileName: String);
305	begin
306	if not FCompileStopped then
307	Update508Monitor(ExtractFileName(FileName), FDFMDataCount, FWarningCount, FErrorCount, FCached, FBuilt, F508ManagersFound);
308	end;
309
310	procedure TVA508Compiler.error(fileName, errorText: string);
311	begin
312	if assigned(FMessageLog) then
313	FMessageLog.add(ERROR_CODE + fileName + ERROR_CODE + errorText);
314	inc(FErrorCount);
315	F508Problems := TRUE;
316	UpdateMonitor(fileName);
317	end;
318
319	procedure TVA508Compiler.warning(fileName, errorText: string);
320	begin
321	if assigned(FMessageLog) then
322	FMessageLog.add(WARNING_CODE + fileName + WARNING_CODE + errorText);
323	inc(FWarningCount);
324	F508Problems := TRUE;
325	UpdateMonitor(fileName);
326	end;
327
328	procedure TVA508Compiler.msg(txt: String);
329	begin
330	if assigned(FMessageLog) then
331	FMessageLog.add(txt);
332	end;
333
334	procedure TVA508Compiler.FileNotification(
335	NotifyCode: TOTAFileNotification; const FileName: string;
336	var Cancel: Boolean);
337	var
338	idx: integer;
339	begin
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;
352	end;
353
354	procedure TVA508Compiler.infoMessage(fileName, infoText: string);
355	begin
356	if assigned(FMessageLog) then
357	FMessageLog.add(INFO_CODE + fileName + INFO_CODE + INFO_ALERT + infoText);
358	UpdateMonitor(fileName);
359	end;
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...
395	procedure TVA508Compiler.ScanFor508Errors(const Project: IOTAProject);
396	const
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
418	var
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
1189	begin
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;
1205	end;
1206	initialization
1207
1208	finalization
1209	Unregister;
1210
1211	end.
1212

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: