| [829] | 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 |
|
|---|
