562 lines
17 KiB
Plaintext
562 lines
17 KiB
Plaintext
unit VA508Classes;
|
|
|
|
interface
|
|
uses SysUtils, Classes, Contnrs, StrUtils, Windows, HRParser, HRParserPas, Forms, Dialogs;
|
|
|
|
type
|
|
TFormData = class
|
|
private
|
|
FFileName: string;
|
|
FlcFormClassName: string;
|
|
FInheritedForm: boolean;
|
|
FParent: TFormData;
|
|
FManagerComponentName: string;
|
|
FInheritedManager: boolean;
|
|
FFormClassName: string;
|
|
FEmptyManager: boolean;
|
|
procedure SetFormClassName(const Value: string);
|
|
public
|
|
function HasManager: boolean;
|
|
function HasParent: boolean;
|
|
property FormClassName: string read FFormClassName write SetFormClassName;
|
|
property lcFormClassName: string read FlcFormClassName;
|
|
property EmptyManager: boolean read FEmptyManager write FEmptyManager;
|
|
property FileName: string read FFileName write FFileName;
|
|
property Parent: TFormData read FParent write FParent;
|
|
property InheritedForm: boolean read FInheritedForm write FInheritedForm;
|
|
property InheritedManager: boolean read FInheritedManager write FInheritedManager;
|
|
property ManagerComponentName: string read FManagerComponentName write FManagerComponentName;
|
|
end;
|
|
|
|
EVA508AccessibilityException = class(Exception);
|
|
|
|
TParentChildErrorCode = (pcNoParentManager, pcValidRelationship,
|
|
pcNoInheritence, pcNoChildComponent, pcEmptyManagerComponent,
|
|
pcOtherChildComponent, pcInheritedNoParent);
|
|
const
|
|
TParentChildPassCodes = [pcNoParentManager, pcValidRelationship];
|
|
TParentChildFailCodes = [pcNoInheritence, pcNoChildComponent, pcEmptyManagerComponent,
|
|
pcOtherChildComponent, pcInheritedNoParent];
|
|
TAutoFixFailCodes = [pcNoInheritence, pcEmptyManagerComponent, pcNoChildComponent, pcInheritedNoParent];
|
|
|
|
type
|
|
TParentChildFormTracker = class
|
|
private
|
|
FData: TObjectList;
|
|
function FindForm(AFormClassName: String): TFormData;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
procedure AddForm(AFileName, AFormClassName, AManagerComponentName: string;
|
|
AEmptyManager: boolean; AInheritedForm, AInheritedManager: boolean);
|
|
procedure AddLink(ParentFormClassName, ChildFormClassName: string);
|
|
function FormCount: integer;
|
|
function GetFormData(index: integer): TFormData;
|
|
function ParentChildErrorStatus(index: integer): TParentChildErrorCode;
|
|
function ParentChildErrorDescription(index: integer): string;
|
|
end;
|
|
|
|
TUnitSection = (usUnknown, usInterface, usImplementation);
|
|
TTokenState = (tsNormal, tsPendingEqualChar, tsPendingClassSymbol, tsPendingParenChar,
|
|
tsPendingClassName, tsPendingEndOfClass);
|
|
|
|
TVA508Parser = class
|
|
private
|
|
FClassName: String;
|
|
FParentClass: String;
|
|
FPendingParentClass: string;
|
|
FParser: THRParserPas;
|
|
FToken: THRToken;
|
|
FLastLine: integer;
|
|
FLastPos: integer;
|
|
FTokenName: String;
|
|
FState: TTokenState;
|
|
FUnitSection: TUnitSection;
|
|
FDone: boolean;
|
|
FIsSymbol: boolean;
|
|
FIsChar: boolean;
|
|
procedure ParseToken;
|
|
public
|
|
function GetParentClassName(ClassName, FileName: String;
|
|
InStream: TStream; var OutStream: TStream): String;
|
|
function LastLineRead: integer;
|
|
function LastPosition: integer;
|
|
end;
|
|
|
|
procedure VA508ComponentCreationCheck(AComponent, AOwner: TComponent;
|
|
AllowDataModules: boolean; ManagerRequired: boolean);
|
|
procedure VA508ComponentDestructionCheck(AComponent: TComponent);
|
|
|
|
const
|
|
NO_OWNER_ERROR = 'Cannot create a %s component without an owner';
|
|
|
|
implementation
|
|
|
|
uses
|
|
VA508AccessibilityManager, VA508ImageListLabeler;
|
|
|
|
const
|
|
MANAGER_CLASS_REQUIRED = 'Cannot create a %s component without a ' + #13#10 +
|
|
'%s component on the same form';
|
|
OTHER_COMPONENTS_DELETED = 'Deleting this %s component also deletes all' + #13#10 +
|
|
'A %s components on this form';
|
|
OWNER_NOT_ALLOWED = 'You may not place a %s component on a %s';
|
|
OWNER_REQUIREMENTS = '%s component can only be added to a %s';
|
|
HAS_EXISTING_MANAGER_ERROR = '%s alread has a %s component';
|
|
|
|
function HasAnotherAccessibilityManager(Root, AComponent: TComponent): boolean;
|
|
var
|
|
i: integer;
|
|
comp: TComponent;
|
|
begin
|
|
Result := false;
|
|
for i := 0 to AComponent.ComponentCount-1 do
|
|
begin
|
|
comp := AComponent.Components[i];
|
|
if (comp <> Root) and (comp is TVA508AccessibilityManager) then
|
|
begin
|
|
Result := true;
|
|
exit;
|
|
end;
|
|
if HasAnotherAccessibilityManager(Root, AComponent.Components[i]) then
|
|
begin
|
|
Result := true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure VA508ComponentCreationCheck(AComponent, AOwner: TComponent;
|
|
AllowDataModules: boolean; ManagerRequired: boolean);
|
|
var
|
|
msg: string;
|
|
|
|
procedure EnsureManager;
|
|
var
|
|
i: integer;
|
|
error: boolean;
|
|
begin
|
|
if (csDesigning in AOwner.ComponentState) and (not (csLoading in AOwner.ComponentState)) then
|
|
begin
|
|
error := TRUE;
|
|
for i := 0 to AOwner.ComponentCount-1 do
|
|
begin
|
|
if AOwner.Components[i] is TVA508AccessibilityManager then
|
|
begin
|
|
error := FALSE;
|
|
break;
|
|
end;
|
|
end;
|
|
if error then
|
|
begin
|
|
raise EVA508AccessibilityException.CreateFmt(MANAGER_CLASS_REQUIRED,
|
|
[AComponent.ClassName, TVA508AccessibilityManager.ClassName]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if not assigned(AOwner) then
|
|
raise EVA508AccessibilityException.CreateFmt(NO_OWNER_ERROR, [AComponent.ClassName]);
|
|
if (AOwner is TDataModule) then
|
|
begin
|
|
if AllowDataModules then
|
|
exit
|
|
else
|
|
raise EVA508AccessibilityException.CreateFmt(OWNER_NOT_ALLOWED, [AComponent.ClassName, TDataModule.ClassName]);
|
|
end;
|
|
if not (AOwner is TCustomForm) then
|
|
begin
|
|
msg := 'Form';
|
|
if AllowDataModules then
|
|
msg := msg + ' or a Data Module';
|
|
raise EVA508AccessibilityException.CreateFmt(OWNER_REQUIREMENTS, [AComponent.ClassName, msg]);
|
|
end;
|
|
if ManagerRequired then
|
|
EnsureManager
|
|
else
|
|
begin
|
|
if HasAnotherAccessibilityManager(AComponent, AOwner) then
|
|
raise EVA508AccessibilityException.Create(Format(HAS_EXISTING_MANAGER_ERROR,
|
|
[AOwner.ClassName, AComponent.ClassName]));
|
|
end;
|
|
end;
|
|
|
|
procedure VA508ComponentDestructionCheck(AComponent: TComponent);
|
|
var
|
|
i: integer;
|
|
list: TObjectList;
|
|
msg: string;
|
|
ComponentAccessFound, ImageListLabelerFound: boolean;
|
|
Owner: TComponent;
|
|
|
|
begin
|
|
if not assigned(AComponent) then exit;
|
|
Owner := AComponent.Owner;
|
|
if not assigned(Owner) then exit;
|
|
if HasAnotherAccessibilityManager(AComponent, Owner) then exit;
|
|
if (csDesigning in AComponent.ComponentState) and (not (csDestroying in Owner.ComponentState)) then
|
|
begin
|
|
list := TObjectList.Create;
|
|
try
|
|
ComponentAccessFound := FALSE;
|
|
ImageListLabelerFound := FALSE;
|
|
for I := 0 to Owner.ComponentCount-1 do
|
|
begin
|
|
if Owner.Components[i] is TVA508ComponentAccessibility then
|
|
begin
|
|
ComponentAccessFound := TRUE;
|
|
list.Add(Owner.Components[i]);
|
|
end
|
|
else
|
|
if Owner.Components[i] is TVA508ImageListLabeler then
|
|
begin
|
|
ImageListLabelerFound := TRUE;
|
|
list.Add(Owner.Components[i]);
|
|
end
|
|
end;
|
|
msg := '';
|
|
if ImageListLabelerFound then
|
|
msg := TVA508ImageListLabeler.ClassName;
|
|
if ComponentAccessFound then
|
|
begin
|
|
if msg <> '' then
|
|
msg := msg + ' and ';
|
|
msg := msg + TVA508ComponentAccessibility.ClassName;
|
|
end;
|
|
if msg <> '' then
|
|
begin
|
|
MessageDlg(Format(OTHER_COMPONENTS_DELETED, [AComponent.ClassName, msg]), mtWarning, [mbOK], 0);
|
|
end;
|
|
finally
|
|
list.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TFormData }
|
|
|
|
function TFormData.HasManager: boolean;
|
|
begin
|
|
Result := ManagerComponentName <> '';
|
|
end;
|
|
|
|
function TFormData.HasParent: boolean;
|
|
begin
|
|
Result := assigned(Parent);
|
|
end;
|
|
|
|
procedure TFormData.SetFormClassName(const Value: string);
|
|
begin
|
|
FFormClassName := Value;
|
|
FlcFormClassName := lowerCase(Value);
|
|
end;
|
|
|
|
{ TParentChildFormTracker }
|
|
|
|
procedure TParentChildFormTracker.AddForm(AFileName, AFormClassName, AManagerComponentName: string;
|
|
AEmptyManager: boolean; AInheritedForm, AInheritedManager: boolean);
|
|
var
|
|
data: TFormData;
|
|
begin
|
|
if FindForm(AFormClassName) = nil then
|
|
begin
|
|
Data := TFormData.Create;
|
|
data.FileName := AFileName;
|
|
data.FormClassName := AFormClassName;
|
|
data.ManagerComponentName := AManagerComponentName;
|
|
data.Parent := nil;
|
|
data.InheritedForm := AInheritedForm;
|
|
data.InheritedManager := AInheritedManager;
|
|
data.EmptyManager := AEmptyManager;
|
|
FData.Add(data);
|
|
end;
|
|
end;
|
|
|
|
procedure TParentChildFormTracker.AddLink(ParentFormClassName, ChildFormClassName: string);
|
|
var
|
|
child,parent: TFormData;
|
|
begin
|
|
child := FindForm(ChildFormClassName);
|
|
parent := FindForm(ParentFormClassName);
|
|
if assigned(child) and assigned(parent) then
|
|
child.Parent := parent;
|
|
end;
|
|
|
|
procedure TParentChildFormTracker.Clear;
|
|
begin
|
|
FData.Clear;
|
|
end;
|
|
|
|
constructor TParentChildFormTracker.Create;
|
|
begin
|
|
FData := TObjectList.Create;
|
|
end;
|
|
|
|
destructor TParentChildFormTracker.Destroy;
|
|
begin
|
|
FData.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TParentChildFormTracker.FindForm(AFormClassName: String): TFormData;
|
|
var
|
|
i: integer;
|
|
name: string;
|
|
begin
|
|
name := lowercase(AFormClassName);
|
|
Result := nil;
|
|
for i := 0 to FData.Count - 1 do
|
|
begin
|
|
if GetFormData(i).lcFormClassName = Name then
|
|
begin
|
|
Result := GetFormData(i);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TParentChildFormTracker.FormCount: integer;
|
|
begin
|
|
Result := FData.Count;
|
|
end;
|
|
|
|
function TParentChildFormTracker.GetFormData(index: integer): TFormData;
|
|
begin
|
|
Result := TFormData(FData[index]);
|
|
end;
|
|
|
|
function TParentChildFormTracker.ParentChildErrorDescription(index: integer): string;
|
|
var
|
|
code: TParentChildErrorCode;
|
|
parent: TFormData;
|
|
child: TFormData;
|
|
begin
|
|
code := ParentChildErrorStatus(index);
|
|
Result := '';
|
|
if code in [pcNoParentManager, pcValidRelationship] then exit;
|
|
child := GetFormData(index);
|
|
parent := child.Parent;
|
|
case code of
|
|
pcNoInheritence: Result := 'Form ' + child.FormClassName + ' descends from form ' + parent.FormClassName +
|
|
' but uses the word "object" instead of "inherited" in the .dfm file.';
|
|
pcNoChildComponent, pcEmptyManagerComponent: Result := 'Form ' + child.FormClassName +
|
|
' .dfm file needs to be rebuilt. To fix manually, view the form as text, then as a form, ' +
|
|
' make sure the form is in a modified state, and save it.';
|
|
pcOtherChildComponent: Result := 'Form ' + child.FormClassName + ' has two ' + TVA508AccessibilityManager.ClassName +
|
|
' components, one from an inherited form, and one on the form.' +
|
|
' Remove the component on the form and use the inherited component';
|
|
pcInheritedNoParent: Result := 'Form ' + child.FormClassName + ' has a ' + TVA508AccessibilityManager.ClassName +
|
|
' component, ' + child.ManagerComponentName +
|
|
', that was inherited from a parent form, but ' + child.ManagerComponentName +
|
|
' has been deleted from the parent form. To Remove the component, view the form as text, then as a form, ' +
|
|
' make sure the form is in a modified state, and save it. Or you can add the ' +
|
|
TVA508AccessibilityManager.ClassName + ' component back onto the parent form.';
|
|
else Result := '';
|
|
end;
|
|
end;
|
|
|
|
function TParentChildFormTracker.ParentChildErrorStatus(
|
|
index: integer): TParentChildErrorCode;
|
|
var
|
|
parent: TFormData;
|
|
child: TFormData;
|
|
bad: boolean;
|
|
|
|
begin
|
|
Result := pcNoParentManager;
|
|
child := GetFormData(index);
|
|
if not assigned(child) then exit;
|
|
|
|
bad := false;
|
|
if child.InheritedManager then
|
|
begin
|
|
bad := not child.HasParent;
|
|
if not bad then
|
|
bad := not child.InheritedForm;
|
|
if not bad then
|
|
bad := not child.Parent.HasManager;
|
|
end;
|
|
|
|
try
|
|
if not child.HasParent then exit;
|
|
parent := child.Parent;
|
|
if not parent.HasManager then exit;
|
|
if child.InheritedForm then
|
|
begin
|
|
if child.HasManager then
|
|
begin
|
|
if (parent.ManagerComponentName = child.ManagerComponentName) and
|
|
(child.InheritedManager) then
|
|
begin
|
|
if child.EmptyManager then
|
|
Result := pcEmptyManagerComponent
|
|
else
|
|
Result := pcValidRelationship
|
|
end
|
|
else
|
|
Result := pcOtherChildComponent
|
|
end
|
|
else
|
|
Result := pcNoChildComponent;
|
|
end
|
|
else
|
|
Result := pcNoInheritence;
|
|
finally
|
|
if bad and (Result = pcNoParentManager) then
|
|
Result := pcInheritedNoParent;
|
|
end;
|
|
end;
|
|
|
|
const
|
|
INTERFACE_NAME = 'interface';
|
|
IMPLEMENTATION_NAME = 'implementation';
|
|
|
|
CLASS_NAME = 'class';
|
|
LEFT_PAREN = '(';
|
|
RIGHT_PAREN = ')';
|
|
COMMA = ',';
|
|
EQUALS = '=';
|
|
|
|
{ TVA508Parser }
|
|
|
|
function TVA508Parser.GetParentClassName(ClassName, FileName: String;
|
|
InStream: TStream; var OutStream: TStream): String;
|
|
begin
|
|
FClassName := lowerCase(ClassName);
|
|
FParentClass := '';
|
|
FState := tsNormal;
|
|
FUnitSection := usUnknown;
|
|
FDone := false;
|
|
|
|
if(assigned(FParser)) then
|
|
FParser.Free;
|
|
FParser := THRParserPas.Create;
|
|
FLastLine := 0;
|
|
FLastPos := 0;
|
|
if assigned(InStream) then
|
|
FParser.Source := InStream
|
|
else
|
|
FParser.Source := TFileStream.Create(FileName, fmOpenRead, fmShareDenyNone);
|
|
try
|
|
while (not FDone) and (FParser.NextToken.TokenType <> HR_TOKEN_EOF) do
|
|
begin
|
|
FToken := FParser.Token;
|
|
FLastLine := FToken.Line;
|
|
FLastPos := FToken.SourcePos;
|
|
ParseToken;
|
|
end;
|
|
finally
|
|
if assigned(InStream) then
|
|
begin
|
|
InStream.Free;
|
|
OutStream := nil;
|
|
end
|
|
else
|
|
OutStream := FParser.Source;
|
|
FreeAndNil(FParser);
|
|
end;
|
|
Result := FParentClass;
|
|
end;
|
|
|
|
function TVA508Parser.LastLineRead: integer;
|
|
begin
|
|
Result := FLastLine;
|
|
end;
|
|
|
|
function TVA508Parser.LastPosition: integer;
|
|
begin
|
|
Result := FLastPos + 1;
|
|
end;
|
|
|
|
procedure TVA508Parser.ParseToken;
|
|
|
|
function IgnoreToken: boolean;
|
|
begin
|
|
if(FUnitSection = usImplementation) then
|
|
begin
|
|
Result := TRUE;
|
|
exit;
|
|
end;
|
|
case FToken.TokenType of
|
|
HR_TOKEN_TEXT_SPACE, HR_TOKEN_PAS_COMMENT_SLASH,
|
|
HR_TOKEN_PAS_COMMENT_BRACE_OPEN, HR_TOKEN_PAS_COMMENT_BRACE,
|
|
HR_TOKEN_PAS_COMMENT_BRACKET_OPEN, HR_TOKEN_PAS_COMMENT_BRACKET:
|
|
Result := TRUE;
|
|
else
|
|
Result := FALSE;
|
|
end;
|
|
end;
|
|
|
|
function InvalidSection: boolean;
|
|
var
|
|
changed: boolean;
|
|
begin
|
|
changed := false;
|
|
if FIsSymbol then
|
|
begin
|
|
if FTokenName = INTERFACE_NAME then
|
|
begin
|
|
FUnitSection := usInterface;
|
|
changed := true;
|
|
end
|
|
else if FTokenName = IMPLEMENTATION_NAME then
|
|
begin
|
|
FUnitSection := usImplementation;
|
|
FDone := TRUE;
|
|
changed := true;
|
|
end;
|
|
end;
|
|
Result := (FUnitSection <> usInterface);
|
|
if changed then
|
|
FState := tsNormal;
|
|
end;
|
|
|
|
begin
|
|
if(IgnoreToken) then exit;
|
|
|
|
FTokenName := LowerCase(FToken.Token);
|
|
FIsSymbol := (FToken.TokenType = HR_TOKEN_TEXT_SYMBOL);
|
|
FIsChar := (FToken.TokenType = HR_TOKEN_CHAR);
|
|
|
|
if(InvalidSection) then exit;
|
|
case FState of
|
|
tsNormal: if FIsSymbol and (FTokenName = FClassName) then
|
|
FState := tsPendingEqualChar;
|
|
tsPendingEqualChar: if FIsChar and (FTokenName = EQUALS) then
|
|
FState := tsPendingClassSymbol
|
|
else
|
|
FState := tsNormal;
|
|
tsPendingClassSymbol: if FIsSymbol and (FTokenName = CLASS_NAME) then
|
|
FState := tsPendingParenChar
|
|
else
|
|
FState := tsNormal;
|
|
tsPendingParenChar: if FIsChar and (FTokenName = LEFT_PAREN) then
|
|
FState := tsPendingClassName
|
|
else
|
|
FState := tsNormal;
|
|
tsPendingClassName: if FIsSymbol then
|
|
begin
|
|
FPendingParentClass := FToken.Token;
|
|
FState := tsPendingEndOfClass;
|
|
end
|
|
else
|
|
FState := tsNormal;
|
|
tsPendingEndOfClass: begin
|
|
if FIsChar and ((FTokenName = RIGHT_PAREN) or
|
|
(FTokenName = COMMA)) then
|
|
begin
|
|
FParentClass := FPendingParentClass;
|
|
FDone := TRUE;
|
|
end;
|
|
FState := tsNormal;
|
|
end;
|
|
else
|
|
FState := tsNormal;
|
|
end;
|
|
end;
|
|
|
|
|
|
end.
|