{ *************************************************************************** } { } { EControl Syntax Editor SDK } { } { Copyright (c) 2004 - 2015 EControl Ltd., Zaharov Michael } { www.econtrol.ru } { support@econtrol.ru } { } { *************************************************************************** } {$mode delphi} unit ecSyntAnal; interface uses Classes, Graphics, Controls, ExtCtrls, Contnrs, SyncObjs, LazUTF8Classes, //TFileStreamUTF8 eczRegExpr, ecStrUtils, ecLists, ecSyntGramma, ATStringProc_TextBuffer, proc_StreamComponent; type IecSyntClient = interface ['{045EAD6D-5584-4A60-849E-6B8994AA5B8F}'] procedure FormatChanged; // Lexer properties changed (update without clear) procedure Finished; // Compleat analysis end; TecLineBreakPos = (lbTop, lbBottom); TecLineBreakBound = set of TecLineBreakPos; // for user blocks TecVertAlignment = (vaTop, vaCenter, vaBottom); TecFormatType = (ftCustomFont, // Any customizing ftFontAttr, // Except custom font ftColor, // Any color ftBackGround);// Only background color TecSyntAnalyzer = class; TecParserResults = class; TecClientSyntAnalyzer = class; TecTagBlockCondition = class; TecSyntaxManager = class; TecSyntaxFormat = class; TecSubAnalyzerRule = class; TecTextRange = class; TOnMatchToken = procedure(Sender: TObject; Client: TecParserResults; const Text: ecString; APos: integer; var MatchLen: integer) of object; TOnBlockCheck = procedure(Sender: TObject; Client: TecClientSyntAnalyzer; const Text: ecString; var RefIdx: integer; var Accept: Boolean) of object; TBoundDefEvent = procedure(Sender: TecClientSyntAnalyzer; Range: TecTextRange; var sIdx, eIdx: integer) of object; TSyntCollectionItem = class(TCollectionItem) private FName: string; FEnabled: Boolean; procedure SetEnabled(const Value: Boolean); protected procedure AssignTo(Dest: TPersistent); override; function GetItemBaseName: string; virtual; function GetDisplayName: string; override; procedure SetDisplayName(const Value: string); override; procedure Loaded; virtual; function GetIsInvalid: Boolean; virtual; public constructor Create(Collection: TCollection); override; property IsInvalid: Boolean read GetIsInvalid; published property DisplayName; property Enabled: Boolean read FEnabled write SetEnabled default True; end; TSyntItemChanged = procedure(Sender: TCollection; Item: TSyntCollectionItem) of object; TSyntCollection = class(TCollection) private FSyntOwner: TecSyntAnalyzer; FOnChange: TSyntItemChanged; function GetItems(Index: integer): TSyntCollectionItem; protected procedure Update(Item: TCollectionItem); override; function GetOwner: TPersistent; override; procedure Loaded; public constructor Create(ItemClass: TCollectionItemClass); function ItemByName(const AName: string): TSyntCollectionItem; function ValidItem(Item: TSyntCollectionItem): Boolean; function GetUniqueName(const Base: string): string; property SyntOwner: TecSyntAnalyzer read FSyntOwner write FSyntOwner; property Items[Index: integer]: TSyntCollectionItem read GetItems; default; property OnChange: TSyntItemChanged read FOnChange write FOnChange; end; TRuleCollectionItem = class(TSyntCollectionItem) private FStyleName: string; FBlockName: string; FFormat: TecSyntaxFormat; FBlock: TecTagBlockCondition; FStrictParent: Boolean; FNotParent: Boolean; FAlwaysEnabled: Boolean; FStatesAbsent: integer; FStatesAdd: integer; FStatesRemove: integer; FStatesPresent: integer; function GetStyleName: string; procedure SetStyleName(const Value: string); function GetBlockName: string; procedure SetBlockName(const Value: string); procedure SetNotParent(const Value: Boolean); procedure SetStrictParent(const Value: Boolean); procedure SetAlwaysEnabled(const Value: Boolean); function GetSyntOwner: TecSyntAnalyzer; procedure SetStatesAdd(const Value: integer); procedure SetStatesAbsent(const Value: integer); procedure SetStatesRemove(const Value: integer); procedure SetStatesPresent(const Value: integer); protected function ValidStyleName(const AStyleName: string; AStyle: TecSyntaxFormat): string; function ValidSetStyle(const AStyleName: string; var AStyleField: string; var AStyle: TecSyntaxFormat): string; procedure AssignTo(Dest: TPersistent); override; procedure Loaded; override; public property Style: TecSyntaxFormat read FFormat write FFormat; property Block: TecTagBlockCondition read FBlock write FBlock; property SyntOwner: TecSyntAnalyzer read GetSyntOwner; published property StyleName: string read GetStyleName write SetStyleName; property BlockName: string read GetBlockName write SetBlockName; property StrictParent: Boolean read FStrictParent write SetStrictParent default False; property NotParent: Boolean read FNotParent write SetNotParent default False; property AlwaysEnabled: Boolean read FAlwaysEnabled write SetAlwaysEnabled default False; property StatesAdd: integer read FStatesAdd write SetStatesAdd default 0; property StatesRemove: integer read FStatesRemove write SetStatesRemove default 0; property StatesPresent: integer read FStatesPresent write SetStatesPresent default 0; property StatesAbsent: integer read FStatesAbsent write SetStatesAbsent default 0; end; // ******************************************************************* // Format for syntax output // ******************************************************************* TecBorderLineType = (blNone, blSolid, blDash, blDot, blDashDot, blDashDotDot, blSolid2, blSolid3, blWavyLine, blDouble); TecFormatFlag = (ffBold, ffItalic, ffUnderline, ffStrikeOut, ffReadOnly, ffHidden, ffFontName, ffFontSize, ffFontCharset, ffVertAlign); TecFormatFlags = set of TecFormatFlag; TecChangeCase = (ccNone, ccUpper, ccLower, ccToggle, ccTitle); TecSyntaxFormat = class(TSyntCollectionItem) private FIsBlock: Boolean; FFont: TFont; FBgColor: TColor; FVertAlign: TecVertAlignment; FFormatType: TecFormatType; FOnChange: TNotifyEvent; FHidden: Boolean; FBorderTypes: array[0..3] of TecBorderLineType; FBorderColors: array[0..3] of TColor; FMultiLineBorder: Boolean; FReadOnly: Boolean; FChangeCase: TecChangeCase; FFormatFlags: TecFormatFlags; procedure SetFont(const Value: TFont); procedure SetBgColor(const Value: TColor); procedure FontChanged(Sender: TObject); procedure SetVertAlign(const Value: TecVertAlignment); procedure SetFormatType(const Value: TecFormatType); procedure SetHidden(const Value: Boolean); function GetBorderColor(Index: Integer): TColor; function GetBorderType(Index: Integer): TecBorderLineType; procedure SetBorderColor(Index: Integer; const Value: TColor); procedure SetBorderType(Index: Integer; const Value: TecBorderLineType); procedure SetMultiLineBorder(const Value: Boolean); procedure SetReadOnly(const Value: Boolean); procedure SetChangeCase(const Value: TecChangeCase); procedure SetFormatFlags(const Value: TecFormatFlags); function GetHidden: Boolean; protected procedure AssignTo(Dest: TPersistent); override; function GetItemBaseName: string; override; procedure Change; dynamic; public constructor Create(Collection: TCollection); override; destructor Destroy; override; function HasBorder: Boolean; procedure ApplyTo(Canvas: TCanvas; AllowChangeFont: Boolean = True); function IsEqual(Other: TecSyntaxFormat): Boolean; // Merges style above this style procedure Merge(Over: TecSyntaxFormat); // Save only common properties procedure Intersect(Over: TecSyntaxFormat); property OnChange: TNotifyEvent read FOnChange write FOnChange; property BorderTypes[Index: integer]: TecBorderLineType read GetBorderType write SetBorderType; property BorderColors[Index: integer]: TColor read GetBorderColor write SetBorderColor; published property Font: TFont read FFont write SetFont; property BgColor: TColor read FBgColor write SetBgColor default clNone; property VertAlignment: TecVertAlignment read FVertAlign write SetVertAlign default vaCenter; property FormatType: TecFormatType read FFormatType write SetFormatType default ftFontAttr; property Hidden: Boolean read GetHidden write SetHidden default False; property BorderTypeLeft: TecBorderLineType index 0 read GetBorderType write SetBorderType default blNone; property BorderColorLeft: TColor index 0 read GetBorderColor write SetBorderColor default clBlack; property BorderTypeTop: TecBorderLineType index 1 read GetBorderType write SetBorderType default blNone; property BorderColorTop: TColor index 1 read GetBorderColor write SetBorderColor default clBlack; property BorderTypeRight: TecBorderLineType index 2 read GetBorderType write SetBorderType default blNone; property BorderColorRight: TColor index 2 read GetBorderColor write SetBorderColor default clBlack; property BorderTypeBottom: TecBorderLineType index 3 read GetBorderType write SetBorderType default blNone; property BorderColorBottom: TColor index 3 read GetBorderColor write SetBorderColor default clBlack; property MultiLineBorder: Boolean read FMultiLineBorder write SetMultiLineBorder default False; property ReadOnly: Boolean read FReadOnly write SetReadOnly default False; property ChangeCase: TecChangeCase read FChangeCase write SetChangeCase default ccNone; property FormatFlags: TecFormatFlags read FFormatFlags write SetFormatFlags default [ffBold, ffItalic, ffUnderline, ffStrikeOut, ffReadOnly, ffHidden, ffFontName, ffFontSize, ffFontCharset, ffVertAlign]; end; TecStylesCollection = class(TSyntCollection) private function GetItem(Index: integer): TecSyntaxFormat; public function Synchronize(Source: TecStylesCollection): integer; constructor Create; function Add: TecSyntaxFormat; property Items[Index: integer]: TecSyntaxFormat read GetItem; default; end; // ******************************************************************* // description classes of text contents // ******************************************************************* TecSyntToken = class(TRange) private FTokenType: integer; FRule: TRuleCollectionItem; function GetStyle: TecSyntaxFormat; public constructor Create(ARule: TRuleCollectionItem; AStartPos, AEndPos: integer); function GetStr(const Source: ecString): ecString; property TokenType: integer read FTokenType; property Rule: TRuleCollectionItem read FRule; property Style: TecSyntaxFormat read GetStyle; end; TecLineBreak = class private FRefTag: integer; FLine: integer; FRule: TecTagBlockCondition; public property Rule: TecTagBlockCondition read FRule; property Line: integer read FLine; property RefIdx: integer read FRefTag; end; TecLineBreakRange = class(TRange) private FRule: TecTagBlockCondition; public property Rule: TecTagBlockCondition read FRule; end; TecTextRange = class(TSortedItem) private FRule: TecTagBlockCondition; FStart, FEnd, FIdent: integer; FStartPos: integer; FParent: TecTextRange; FCondIndex: integer; FEndCondIndex: integer; FIndex: integer; function GetLevel: integer; function GetIsClosed: Boolean; protected function GetKey: integer; override; public constructor Create(AStartIdx, AStartPos: integer); function IsParent(Range: TecTextRange): Boolean; property Rule: TecTagBlockCondition read FRule; property StartIdx: integer read FStart; property EndIdx: integer read FEnd; property IdentIdx: integer read FIdent; property Parent: TecTextRange read FParent; property Level: integer read GetLevel; property Index: integer read FIndex; property StartPos: Integer read FStartPos; property IsClosed: Boolean read GetIsClosed; end; TecSubLexerRange = class(TRange) private FRule: TecSubAnalyzerRule; // Rule reference FCondEndPos: integer; // Start pos of the start condition FCondStartPos: integer; // End pos of the end condition public property Rule: TecSubAnalyzerRule read FRule; property CondStartPos: integer read FCondStartPos; property CondEndPos: integer read FCondEndPos; end; // ******************************************************************* // Rules for syntax interpretation // ******************************************************************* TecTagConditionType = (tcEqual, tcNotEqual, tcMask, tcSkip, tcStrictMask); TecSingleTagCondition = class(TCollectionItem) private FTagList: TStrings; FCondType: TecTagConditionType; FTokenTypes: DWORD; procedure SetTagList(const Value: TStrings); procedure SetIgnoreCase(const Value: Boolean); procedure SetTokenTypes(const Value: DWORD); procedure SetCondType(const Value: TecTagConditionType); procedure TagListChanged(Sender: TObject); function GetIgnoreCase: Boolean; protected procedure AssignTo(Dest: TPersistent); override; public constructor Create(Collection: TCollection); override; destructor Destroy; override; function CheckToken(const Source: ecString; Token: TecSyntToken): Boolean; published property TagList: TStrings read FTagList write SetTagList; property CondType: TecTagConditionType read FCondType write SetCondType default tcEqual; property TokenTypes: DWORD read FTokenTypes write SetTokenTypes default 0; property IgnoreCase: Boolean read GetIgnoreCase write SetIgnoreCase default False; end; TecConditionCollection = class(TCollection) private FOwner: TecTagBlockCondition; FOnChange: TNotifyEvent; function GetItem(Index: integer): TecSingleTagCondition; protected procedure Update(Item: TCollectionItem); override; function GetOwner: TPersistent; override; public constructor Create(AOwner: TecTagBlockCondition); function Add: TecSingleTagCondition; property Items[Index: integer]: TecSingleTagCondition read GetItem; default; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TecTagBlockType = (btTagDetect, btLineBreak, btRangeStart, btRangeEnd); TecHighlightPos = (cpAny, cpBound, cpBoundTag, cpRange, cpBoundTagBegin, cpOutOfRange); TecDynamicHighlight = (dhNone, dhBound, dhRangeNoBound, dhRange); TecAutoCloseMode = (acmDisabled, acmCloseNearest, acmCloseOpened); TecTagBlockCondition = class(TRuleCollectionItem) private FConditions: TecConditionCollection; FIdentIndex: integer; FLinePos: TecLineBreakPos; FBlockOffset: integer; FBlockEndCond: TecTagBlockCondition; FBlockType: TecTagBlockType; FBlockEndName: string; FEndOfTextClose: Boolean; FNotCollapsed: Boolean; FSameIdent: Boolean; FInvertColors: Boolean; FHighlight: Boolean; FDisplayInTree: Boolean; FNameFmt: ecString; FGroupFmt: ecString; FRefToCondEnd: Boolean; FDynHighlight: TecDynamicHighlight; FHighlightPos: TecHighlightPos; FDynSelectMin: Boolean; FCancelNextRules: Boolean; FOnBlockCheck: TOnBlockCheck; FDrawStaple: Boolean; FGroupIndex: integer; FCollapseFmt: ecString; FSelfClose: Boolean; FNoEndRule: Boolean; FGrammaRuleName: string; FGrammaRule: TParserRule; FTokenType: integer; FTreeItemStyle: string; FTreeItemStyleObj: TecSyntaxFormat; FTreeGroupStyle: string; FTreeGroupStyleObj: TecSyntaxFormat; FTreeGroupImage: integer; FTreeItemImage: integer; FUseCustomPen: Boolean; FPen: TPen; FIgnoreAsParent: Boolean; FAutoCloseText: ecString; FAutoCloseMode: TecAutoCloseMode; procedure ConditionsChanged(Sender: TObject); function GetBlockEndName: string; procedure SetBlockEndName(const Value: string); procedure SetBlockType(const Value: TecTagBlockType); procedure SetConditions(const Value: TecConditionCollection); procedure SetBlockEndCond(const Value: TecTagBlockCondition); procedure SetLinePos(const Value: TecLineBreakPos); procedure SetIdentIndex(const Value: integer); procedure SetBlockOffset(const Value: integer); procedure SetEndOfTextClose(const Value: Boolean); procedure SetNotCollapsed(const Value: Boolean); procedure SetSameIdent(const Value: Boolean); procedure SetHighlight(const Value: Boolean); procedure SetInvertColors(const Value: Boolean); procedure SetDisplayInTree(const Value: Boolean); procedure SetCancelNextRules(const Value: Boolean); procedure SetDynHighlight(const Value: TecDynamicHighlight); procedure SetDynSelectMin(const Value: Boolean); procedure SetGroupFmt(const Value: ecString); procedure SetHighlightPos(const Value: TecHighlightPos); procedure SetNameFmt(const Value: ecString); procedure SetRefToCondEnd(const Value: Boolean); procedure SetDrawStaple(const Value: Boolean); procedure SetCollapseFmt(const Value: ecString); procedure SetSelfClose(const Value: Boolean); procedure SetNoEndRule(const Value: Boolean); procedure SetGrammaRuleName(const Value: string); procedure SetTokenType(const Value: integer); function GetTreeItemStyle: string; procedure SetTreeItemStyle(const Value: string); function GetTreeGroupStyle: string; procedure SetTreeGroupStyle(const Value: string); procedure SetTreeGroupImage(const Value: integer); procedure SetTreeItemImage(const Value: integer); procedure SetPen(const Value: TPen); procedure SetUseCustomPen(const Value: Boolean); procedure SetIgnoreAsParent(const Value: Boolean); procedure SetAutoCloseText(Value: ecString); procedure SetAutoCloseMode(const Value: TecAutoCloseMode); protected procedure AssignTo(Dest: TPersistent); override; function GetItemBaseName: string; override; procedure Loaded; override; function CheckOffset: integer; public constructor Create(Collection: TCollection); override; destructor Destroy; override; function Check(const Source: ecString; Tags: TecClientSyntAnalyzer; N: integer; var RefIdx: integer): Boolean; property BlockEndCond: TecTagBlockCondition read FBlockEndCond write SetBlockEndCond; property TreeItemStyleObj: TecSyntaxFormat read FTreeItemStyleObj; property TreeGroupStyleObj: TecSyntaxFormat read FTreeGroupStyleObj; published property BlockType: TecTagBlockType read FBlockType write SetBlockType default btRangeStart; property ConditionList: TecConditionCollection read FConditions write SetConditions; property IdentIndex: integer read FIdentIndex write SetIdentIndex default 0; property LinePos: TecLineBreakPos read FLinePos write SetLinePos default lbTop; property BlockOffset: integer read FBlockOffset write SetBlockOffset default 0; property BlockEnd: string read GetBlockEndName write SetBlockEndName; property EndOfTextClose: Boolean read FEndOfTextClose write SetEndOfTextClose default False; property NotCollapsed: Boolean read FNotCollapsed write SetNotCollapsed default False; property SameIdent: Boolean read FSameIdent write SetSameIdent default False; property Highlight: Boolean read FHighlight write SetHighlight default False; property InvertColors: Boolean read FInvertColors write SetInvertColors default False; property DisplayInTree: Boolean read FDisplayInTree write SetDisplayInTree default True; property NameFmt: ecString read FNameFmt write SetNameFmt; property GroupFmt: ecString read FGroupFmt write SetGroupFmt; property RefToCondEnd: Boolean read FRefToCondEnd write SetRefToCondEnd default False; property DynHighlight: TecDynamicHighlight read FDynHighlight write SetDynHighlight default dhNone; property HighlightPos: TecHighlightPos read FHighlightPos write SetHighlightPos; property DynSelectMin: Boolean read FDynSelectMin write SetDynSelectMin default False; property CancelNextRules: Boolean read FCancelNextRules write SetCancelNextRules default False; property DrawStaple: Boolean read FDrawStaple write SetDrawStaple default False; property GroupIndex: integer read FGroupIndex write FGroupIndex default 0; property CollapseFmt: ecString read FCollapseFmt write SetCollapseFmt; property OnBlockCheck: TOnBlockCheck read FOnBlockCheck write FOnBlockCheck; property SelfClose: Boolean read FSelfClose write SetSelfClose default False; // New in v2.20 property NoEndRule: Boolean read FNoEndRule write SetNoEndRule default False; property GrammaRuleName: string read FGrammaRuleName write SetGrammaRuleName; property TokenType: integer read FTokenType write SetTokenType default -1; property TreeItemStyle: string read GetTreeItemStyle write SetTreeItemStyle; property TreeGroupStyle: string read GetTreeGroupStyle write SetTreeGroupStyle; property TreeItemImage: integer read FTreeItemImage write SetTreeItemImage default -1; property TreeGroupImage: integer read FTreeGroupImage write SetTreeGroupImage default -1; // New in 2.40 property Pen: TPen read FPen write SetPen; property UseCustomPen: Boolean read FUseCustomPen write SetUseCustomPen default False; property IgnoreAsParent: Boolean read FIgnoreAsParent write SetIgnoreAsParent; // New in 2.50 property AutoCloseMode: TecAutoCloseMode read FAutoCloseMode write SetAutoCloseMode default acmDisabled; property AutoCloseText: ecString read FAutoCloseText write SetAutoCloseText; end; TecBlockRuleCollection = class(TSyntCollection) private function GetItem(Index: integer): TecTagBlockCondition; public constructor Create; function Add: TecTagBlockCondition; property Items[Index: integer]: TecTagBlockCondition read GetItem; default; end; // Token identification rule TecTokenRule = class(TRuleCollectionItem) private FRegExpr: TecRegExpr; FTokenType: integer; FOnMatchToken: TOnMatchToken; FColumnTo: integer; FColumnFrom: integer; function GetExpression: ecString; procedure SetExpression(const Value: ecString); procedure SetTokenType(const Value: integer); procedure SetColumnFrom(const Value: integer); procedure SetColumnTo(const Value: integer); protected procedure AssignTo(Dest: TPersistent); override; function GetItemBaseName: string; override; function GetIsInvalid: Boolean; override; public constructor Create(Collection: TCollection); override; destructor Destroy; override; function Match(const Source: ecString; Pos: integer): integer; published property TokenType: integer read FTokenType write SetTokenType default 0; property Expression: ecString read GetExpression write SetExpression; property ColumnFrom: integer read FColumnFrom write SetColumnFrom; property ColumnTo: integer read FColumnTo write SetColumnTo; property OnMatchToken: TOnMatchToken read FOnMatchToken write FOnMatchToken; end; TecTokenRuleCollection = class(TSyntCollection) private function GetItem(Index: integer): TecTokenRule; public constructor Create; function Add: TecTokenRule; property Items[Index: integer]: TecTokenRule read GetItem; default; end; TecSubAnalyzerRule = class(TRuleCollectionItem) private FStartRegExpr: TecRegExpr; FEndRegExpr: TecRegExpr; FSyntAnalyzer: TecSyntAnalyzer; FFromTextBegin: Boolean; FToTextEnd: Boolean; FIncludeBounds: Boolean; function GetEndExpression: string; function GetStartExpression: string; procedure SetEndExpression(const Value: string); procedure SetStartExpression(const Value: string); procedure SetSyntAnalyzer(const Value: TecSyntAnalyzer); procedure SetFromTextBegin(const Value: Boolean); procedure SetToTextEnd(const Value: Boolean); procedure SetIncludeBounds(const Value: Boolean); protected procedure AssignTo(Dest: TPersistent); override; function GetItemBaseName: string; override; public constructor Create(Collection: TCollection); override; destructor Destroy; override; function MatchStart(const Source: ecString; Pos: integer): integer; function MatchEnd(const Source: ecString; Pos: integer): integer; published property StartExpression: string read GetStartExpression write SetStartExpression; property EndExpression: string read GetEndExpression write SetEndExpression; property SyntAnalyzer: TecSyntAnalyzer read FSyntAnalyzer write SetSyntAnalyzer; property FromTextBegin: Boolean read FFromTextBegin write SetFromTextBegin default False; property ToTextEnd: Boolean read FToTextEnd write SetToTextEnd default False; property IncludeBounds: Boolean read FIncludeBounds write SetIncludeBounds default False; end; TecSubAnalyzerRules = class(TSyntCollection) private function GetItem(Index: integer): TecSubAnalyzerRule; public constructor Create; function Add: TecSubAnalyzerRule; property Items[Index: integer]: TecSubAnalyzerRule read GetItem; default; end; { TecCodeTemplate } TecCodeTemplate = class(TCollectionItem) private FName: string; FDescription: string; FAdvanced: boolean; FCode: TStrings; protected function GetDisplayName: string; override; public constructor Create(Collection: TCollection); override; destructor Destroy; override; published property Name: string read FName write FName; property Description: string read FDescription write FDescription; property Advanced: Boolean read FAdvanced write FAdvanced; property Code: TStrings read FCode; end; TecCodeTemplates = class(TOwnedCollection) private function GetItem(Index: integer): TecCodeTemplate; public constructor Create(AOwner: TPersistent); function Add: TecCodeTemplate; property Items[Index: integer]: TecCodeTemplate read GetItem; default; end; TecChangeFixer = class private FList: TList; public constructor Create; destructor Destroy; override; procedure Clear; procedure Add(Pos, Count: integer); function CurToOld(CurPos: integer): integer; function OldToCur(OldPos: integer): integer; function UpOldNoChange: integer; end; // ******************************************************************* // Parser classes // // ******************************************************************* // ******************************************************************* // Syntax analizer for single client // container of description objects // ******************************************************************* TecParserResults = class(TTokenHolder) private FSrcProc: TATStringBuffer; FClient: IecSyntClient; FOwner: TecSyntAnalyzer; FFinished: Boolean; FSubLexerBlocks: TList; // Sub Lexer Text Ranges FTagList: TRangeList; // List of tokens FCurState: integer; FStateChanges: TList; function GetLastPos(const Source: ecString): integer; function ExtractTag(const Source: ecString; var FPos: integer; IsIdle: Boolean): Boolean; function GetTags(Index: integer): TecSyntToken; function GetSubLexerRangeCount: integer; function GetSubLexerRange(Index: integer): TecSubLexerRange; protected function GetTokenCount: integer; override; function GetTokenStr(Index: integer): ecString; override; function GetTokenType(Index: integer): integer; override; procedure CloseAtEnd(StartTagIdx: integer); virtual; abstract; protected FLastAnalPos: integer; procedure Finished; virtual; function IsEnabled(Rule: TRuleCollectionItem; OnlyGlobal: Boolean): Boolean; virtual; procedure ApplyStates(Rule: TRuleCollectionItem); procedure SaveState; procedure RestoreState; public constructor Create(AOwner: TecSyntAnalyzer; SrcProc: TATStringBuffer; const AClient: IecSyntClient); virtual; destructor Destroy; override; procedure Clear; virtual; function AnalyzerAtPos(Pos: integer): TecSyntAnalyzer; function ParserStateAtPos(TokenIndex: integer): integer; property Owner: TecSyntAnalyzer read FOwner; property IsFinished: Boolean read FFinished; property TagStr[Index: integer]: ecString read GetTokenStr; property TagCount: integer read GetTokenCount; property Tags[Index: integer]: TecSyntToken read GetTags; default; property SubLexerRangeCount: integer read GetSubLexerRangeCount; property SubLexerRanges[Index: integer]: TecSubLexerRange read GetSubLexerRange; property ParserState: integer read FCurState write FCurState; end; TecClientSyntAnalyzer = class(TecParserResults) private FLineBreaks: TList; FRanges: TSortedList; FOpenedBlocks: TSortedList; // Opened ranges (without end) FBreakIdle: Boolean; FIdleProc: Boolean; FIdleTimer: TTimer; FSavedTags: TRangeList; // saved tokens FChanges: TecChangeFixer; // fixes all changes before objects will be updated FLineBreakRanges: TRangeCollection;// ranges maked with line breaks FDataAccess: TCriticalSection; FNextTokIndex: integer; FStartSepRangeAnal: integer; FDisableIdleAppend: Boolean; FRepeateAnalysis: Boolean; function GetRangeCount: integer; function GetRanges(Index: integer): TecTextRange; function GetTagPos(Index: integer): TPoint; function GetOpened(Index: integer): TecTextRange; function GetOpenedCount: integer; procedure SetDisableIdleAppend(const Value: Boolean); protected procedure AddLineBreak(lb: TecLineBreak); procedure AddRange(Range: TecTextRange); function HasOpened(Rule: TRuleCollectionItem; Parent: TecTagBlockCondition; Strict: Boolean): Boolean; function IsEnabled(Rule: TRuleCollectionItem; OnlyGlobal: Boolean): Boolean; override; procedure Finished; override; procedure IntIdleAppend(Sender: TObject); procedure CloseAtEnd(StartTagIdx: integer); override; public constructor Create(AOwner: TecSyntAnalyzer; SrcProc: TATStringBuffer; const AClient: IecSyntClient); override; destructor Destroy; override; procedure Clear; override; procedure ChangedAtPos(APos: integer); function GetLineBreak(Line: integer): TecLineBreakRange; function TokenAtPos(Pos: integer): integer; function PriorTokenAt(Pos: integer): integer; function NextTokenAt(Pos: integer): integer; function GetRangeBound(Range: TecTextRange): TPoint; function GetColRangeBound(Range: TecTextRange): TPoint; function RangeAtPos(APos: integer): TecTextRange; function RangeIdxAtPos(APos: integer): integer; function NearestRangeAtPos(APos: integer): TecTextRange; function NearestRangeIdxAtPos(APos: integer): integer; function RangeFormat(const FmtStr: ecString; Range: TecTextRange): ecString; function GetRangeName(Range: TecTextRange): ecString; function GetRangeGroup(Range: TecTextRange): ecString; function GetCollapsedText(Range: TecTextRange): ecString; function GetAutoCloseText(Range: TecTextRange; const Indent: string): ecString; procedure TextChanged(Pos, Count: integer); procedure TryAppend(APos: integer); // Tries to analyze to APos procedure AppendToPos(APos: integer); // Requires analyzed to APos procedure Analyze(ResetContent: Boolean = True); // Requires analyzed all text procedure IdleAppend; // Start idle analysis procedure CompleteAnalysis; procedure Lock; procedure Unlock; function CloseRange(Cond: TecTagBlockCondition; RefTag: integer): Boolean; function CreateLineBreak(Rule: TecTagBlockCondition; RefTag: integer): Boolean; function DetectTag(Rule: TecTagBlockCondition; RefTag: integer): Boolean; property OpenCount: integer read GetOpenedCount; property Opened[Index: integer]: TecTextRange read GetOpened; property LineBreaks: TList read FLineBreaks; property RangeCount: integer read GetRangeCount; property Ranges[Index: integer]: TecTextRange read GetRanges; property TagPos[Index: integer]: TPoint read GetTagPos; property DisableIdleAppend: Boolean read FDisableIdleAppend write SetDisableIdleAppend; end; // ******************************************************************* // Syntax analizer // container of syntax rules // ******************************************************************* TLoadableComponent = class(TComponent) private FSkipNewName: Boolean; FFileName: string; FIgnoreAll: Boolean; FSaving: Boolean; protected procedure OnReadError(Reader: TReader; const Message: string; var Handled: Boolean); virtual; function NotStored: Boolean; public procedure SaveToFile(const FileName: string); virtual; procedure SaveToStream(Stream: TStream); virtual; procedure LoadFromFile(const FileName: string); virtual; procedure LoadFromResourceID(Instance: Cardinal; ResID: Integer; ResType: string); virtual; procedure LoadFromResourceName(Instance: Cardinal; const ResName: string; ResType: string); virtual; procedure LoadFromStream(const Stream: TStream); virtual; protected procedure SetName(const NewName: TComponentName); override; property FileName: string read FFileName write LoadFromFile; end; TParseTokenEvent = procedure(Client: TecParserResults; const Text: ecString; Pos: integer; var TokenLength: integer; var Rule: TecTokenRule) of object; TecSyntAnalyzer = class(TLoadableComponent) private FClientList: TList; FMasters: TList; // Master lexer, i.e. lexers that uses it FOnChange: TNotifyEvent; FSampleText: TStrings; FFormats: TecStylesCollection; FTokenRules: TecTokenRuleCollection; FBlockRules: TecBlockRuleCollection; FCodeTemplates: TecCodeTemplates; FExtentions: string; FLexerName: string; FCoping: Boolean; FSkipSpaces: Boolean; FSubAnalyzers: TecSubAnalyzerRules; FTokenTypeNames: TStrings; FFullRefreshSize: integer; FMarkedBlock: TecSyntaxFormat; FMarkedBlockName: string; FSearchMatch: TecSyntaxFormat; FSearchMatchName: string; FCurrentLine: TecSyntaxFormat; FCurrentLineName: string; FDefStyle: TecSyntaxFormat; FDefStyleName: string; FCollapseStyle: TecSyntaxFormat; FCollapseStyleName: string; FNotes: TStrings; FInternal: boolean; FRestartFromLineStart: Boolean; FParseEndOfLine: Boolean; FGrammaParser: TGrammaAnalyzer; FLineComment: ecString; FCharset: TFontCharSet; FSeparateBlocks: integer; FAlwaysSyncBlockAnal: Boolean; // Indicates that blocks analysis may after tokens FOnGetCollapseRange: TBoundDefEvent; FOnCloseTextRange: TBoundDefEvent; FIdleAppendDelayInit: Cardinal; FIdleAppendDelay: Cardinal; FOnParseToken: TParseTokenEvent; procedure SetSampleText(const Value: TStrings); procedure FormatsChanged(Sender: TCollection; Item: TSyntCollectionItem); procedure TokenRuleChanged(Sender: TCollection; Item: TSyntCollectionItem); procedure BlocksChanged(Sender: TCollection; Item: TSyntCollectionItem); procedure SubLexRuleChanged(Sender: TCollection; Item: TSyntCollectionItem); procedure SetBlockRules(const Value: TecBlockRuleCollection); procedure SetCodeTemplates(const Value: TecCodeTemplates); procedure SetTokenRules(const Value: TecTokenRuleCollection); procedure SetFormats(const Value: TecStylesCollection); function GetUniqueName(const Base: string): string; procedure SetSkipSpaces(const Value: Boolean); procedure SetSubAnalyzers(const Value: TecSubAnalyzerRules); procedure SetTokenTypeNames(const Value: TStrings); function GetStyleName(const AName: string; const AStyle: TecSyntaxFormat): string; procedure SetMarkedBlock(const Value: TecSyntaxFormat); function GetMarkedBlockName: string; procedure SetMarkedBlockName(const Value: string); procedure SetSearchMatch(const Value: TecSyntaxFormat); function GetSearchMatchStyle: string; procedure SetSearchMatchStyle(const Value: string); procedure SetCurrentLine(const Value: TecSyntaxFormat); function GetCurrentLineStyle: string; procedure SetCurrentLineStyle(const Value: string); procedure SetNotes(const Value: TStrings); procedure SetInternal(const Value: boolean); procedure SetRestartFromLineStart(const Value: Boolean); procedure SetParseEndOfLine(const Value: Boolean); procedure TokenNamesChanged(Sender: TObject); procedure CompileGramma; procedure SetGrammar(const Value: TGrammaAnalyzer); procedure GrammaChanged(Sender: TObject); procedure SetDefStyle(const Value: TecSyntaxFormat); function GetDefaultStyleName: string; procedure SetDefaultStyleName(const Value: string); procedure SetLineComment(const Value: ecString); procedure DetectBlockSeparate; procedure SetAlwaysSyncBlockAnal(const Value: Boolean); function GetCollapseStyleName: string; procedure SetCollapseStyleName(const Value: string); procedure SetCollapseStyle(const Value: TecSyntaxFormat); function GetSeparateBlocks: Boolean; protected function GetToken(Client: TecParserResults; const Source: ecString; APos: integer; OnlyGlobal: Boolean): TecSyntToken; virtual; procedure HighlightKeywords(Client: TecParserResults; const Source: ecString; OnlyGlobal: Boolean); virtual; procedure SelectTokenFormat(Client: TecParserResults; const Source: ecString; OnlyGlobal: Boolean; N: integer = -1); virtual; procedure Loaded; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Change; dynamic; property SeparateBlockAnalysis: Boolean read GetSeparateBlocks; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function AddClient(const Client: IecSyntClient; SrcProc: TATStringBuffer): TecClientSyntAnalyzer; procedure ClearClientContents; procedure UpdateClients; procedure AddMasterLexer(SyntAnal: TecSyntAnalyzer); procedure RemoveMasterLexer(SyntAnal: TecSyntAnalyzer); property MarkedBlock: TecSyntaxFormat read FMarkedBlock write SetMarkedBlock; property SearchMatch: TecSyntaxFormat read FSearchMatch write SetSearchMatch; property CurrentLine: TecSyntaxFormat read FCurrentLine write SetCurrentLine; property DefStyle: TecSyntaxFormat read FDefStyle write SetDefStyle; property CollapseStyle: TecSyntaxFormat read FCollapseStyle write SetCollapseStyle; published property Formats: TecStylesCollection read FFormats write SetFormats; property TokenRules: TecTokenRuleCollection read FTokenRules write SetTokenRules; property BlockRules: TecBlockRuleCollection read FBlockRules write SetBlockRules; property CodeTemplates: TecCodeTemplates read FCodeTemplates write SetCodeTemplates; property SubAnalyzers: TecSubAnalyzerRules read FSubAnalyzers write SetSubAnalyzers; property SampleText: TStrings read FSampleText write SetSampleText; property TokenTypeNames: TStrings read FTokenTypeNames write SetTokenTypeNames; property Gramma: TGrammaAnalyzer read FGrammaParser write SetGrammar; property MarkedBlockStyle: string read GetMarkedBlockName write SetMarkedBlockName; property SearchMatchStyle: string read GetSearchMatchStyle write SetSearchMatchStyle; property CurrentLineStyle: string read GetCurrentLineStyle write SetCurrentLineStyle; property DefaultStyleName: string read GetDefaultStyleName write SetDefaultStyleName; property CollapseStyleName: string read GetCollapseStyleName write SetCollapseStyleName; property Extentions: string read FExtentions write FExtentions; property LexerName: string read FLexerName write FLexerName; property SkipSpaces: Boolean read FSkipSpaces write SetSkipSpaces default True; property FullRefreshSize: integer read FFullRefreshSize write FFullRefreshSize default 0; property Notes: TStrings read FNotes write SetNotes; property Internal: boolean read FInternal write SetInternal default False; property RestartFromLineStart: Boolean read FRestartFromLineStart write SetRestartFromLineStart default False; property ParseEndOfLine: Boolean read FParseEndOfLine write SetParseEndOfLine default False; property LineComment: ecString read FLineComment write SetLineComment; property Charset: TFontCharSet read FCharset write FCharset; //AT property AlwaysSyncBlockAnal: Boolean read FAlwaysSyncBlockAnal write SetAlwaysSyncBlockAnal default False; property IdleAppendDelay: Cardinal read FIdleAppendDelay write FIdleAppendDelay default 200; property IdleAppendDelayInit: Cardinal read FIdleAppendDelayInit write FIdleAppendDelayInit default 50; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnGetCollapseRange: TBoundDefEvent read FOnGetCollapseRange write FOnGetCollapseRange; property OnCloseTextRange: TBoundDefEvent read FOnCloseTextRange write FOnCloseTextRange; property OnParseToken: TParseTokenEvent read FOnParseToken write FOnParseToken; end; TLibSyntAnalyzer = class(TecSyntAnalyzer) protected FParent: TecSyntaxManager; // function GetChildParent: TComponent; override; // procedure SetName(const NewName: TComponentName); override; procedure SetParentComponent(Value: TComponent); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure LoadFromStream(const Stream: TStream); override; function GetParentComponent: TComponent; override; function HasParent: Boolean; override; end; TecSyntaxManager = class(TLoadableComponent) private FOnChange: TNotifyEvent; FList: TList; FCurrentLexer: TecSyntAnalyzer; FOnLexerChanged: TNotifyEvent; FModified: Boolean; function GeItem(Index: integer): TecSyntAnalyzer; function GetCount: integer; procedure SetCurrentLexer(const Value: TecSyntAnalyzer); protected procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Changed; dynamic; procedure OnReadError(Reader: TReader; const Message: string; var Handled: Boolean); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure LoadFromFile(const FileName: string); override; procedure SaveToFile(const FileName: string); override; function FindAnalyzer(const LexerName: string): TecSyntAnalyzer; function AddAnalyzer: TecSyntAnalyzer; procedure Clear; procedure Move(CurIndex, NewIndex: Integer); property AnalyzerCount: integer read GetCount; property Analyzers[Index: integer]: TecSyntAnalyzer read GeItem; property FileName; property CurrentLexer: TecSyntAnalyzer read FCurrentLexer write SetCurrentLexer; property Modified: Boolean read FModified write FModified; published property OnLexerChanged: TNotifyEvent read FOnLexerChanged write FOnLexerChanged stored NotStored; property OnChange: TNotifyEvent read FOnChange write FOnChange stored NotStored; end; TecSyntStyles = class(TLoadableComponent) private FStyles: TecStylesCollection; procedure SetStyles(const Value: TecStylesCollection); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Styles: TecStylesCollection read FStyles write SetStyles; end; implementation uses SysUtils, Forms, Dialogs, Math, ecSysUtils; const SecDefaultTokenTypeNames = 'Unknown' + #13#10 + 'Comment' + #13#10 + 'Id' + #13#10 + 'Symbol' + #13#10 + 'String' + #13#10 + 'Number' + #13#10 + 'Preprocessor'; //local copy of ecUpCase. it is faster, uses AnsiChar UpCase. function ecUpCase(ch: WideChar): char; begin Result:= system.UpCase(char(ch)); end; procedure SetDefaultModifiers(RE: TecRegExpr); begin RE.ModifierI := True; RE.ModifierG := True; RE.ModifierS := False; RE.ModifierM := True; RE.ModifierX := True; RE.ModifierR := False; end; { TecSyntToken } constructor TecSyntToken.Create(ARule: TRuleCollectionItem; AStartPos, AEndPos: integer); begin inherited Create(AStartPos, AEndPos); FRule := ARule; FTokenType := TecTokenRule(ARule).TokenType; end; function TecSyntToken.GetStr(const Source: ecString): ecString; begin Result := Copy(Source, StartPos + 1, EndPos - StartPos); end; function TecSyntToken.GetStyle: TecSyntaxFormat; begin if Rule = nil then Result := nil else Result := Rule.Style; end; { TecTextRange } constructor TecTextRange.Create(AStartIdx, AStartPos: integer); begin inherited Create; FStart := AStartIdx; FStartPos := AStartPos; FEnd := -1; FEndCondIndex := -1; FIndex := -1; end; function TecTextRange.GetIsClosed: Boolean; begin Result := FEnd <> -1; end; function TecTextRange.GetKey: integer; begin Result := FStartPos; end; function TecTextRange.GetLevel: integer; var prn: TecTextRange; begin prn := Parent; Result := 0; while prn <> nil do begin inc(Result); prn := prn.Parent; end; end; function TecTextRange.IsParent(Range: TecTextRange): Boolean; begin if Range = FParent then Result := True else if Assigned(FParent) then Result := FParent.IsParent(Range) else Result := False; end; { TSyntCollectionItem } procedure TSyntCollectionItem.AssignTo(Dest: TPersistent); begin if Dest is TSyntCollectionItem then begin (Dest as TSyntCollectionItem).DisplayName := DisplayName; (Dest as TSyntCollectionItem).Enabled := Enabled; end; end; constructor TSyntCollectionItem.Create(Collection: TCollection); var NewName: string; n: integer; begin inherited; FEnabled := True; if Collection = nil then Exit; n := 1; repeat NewName := GetItemBaseName + ' ' + IntToStr(n); inc(n); until TSyntCollection(Collection).ItemByName(NewName) = nil; FName := NewName; end; function TSyntCollectionItem.GetDisplayName: string; begin Result := FName; end; function TSyntCollectionItem.GetIsInvalid: Boolean; begin Result := False; end; function TSyntCollectionItem.GetItemBaseName: string; begin Result := 'Item'; end; procedure TSyntCollectionItem.Loaded; begin end; procedure TSyntCollectionItem.SetDisplayName(const Value: string); var i: integer; begin if Collection <> nil then for i := 0 to Collection.Count - 1 do if Collection.Items[i] <> Self then if Collection.Items[i].DisplayName = Value then Exit; FName := Value; end; procedure TSyntCollectionItem.SetEnabled(const Value: Boolean); begin if FEnabled <> Value then begin FEnabled := Value; Changed(False); end; end; { TSyntCollection } constructor TSyntCollection.Create(ItemClass: TCollectionItemClass); begin if not ItemClass.InheritsFrom(TSyntCollectionItem) then raise Exception.Create('Allow only TSyntCollectionItem Class'); inherited; end; function TSyntCollection.GetItems(Index: integer): TSyntCollectionItem; begin Result := (inherited Items[Index]) as TSyntCollectionItem; end; function TSyntCollection.GetOwner: TPersistent; begin Result := FSyntOwner; end; function TSyntCollection.GetUniqueName(const Base: string): string; var n: integer; begin Result := Base; n := 0; while ItemByName(Result) <> nil do begin Inc(n); Result := Base + IntToStr(n); end; end; function TSyntCollection.ItemByName(const AName: string): TSyntCollectionItem; var i: integer; begin for i := 0 to Count - 1 do if Items[i].DisplayName = AName then begin Result := Items[i] as TSyntCollectionItem; Exit; end; Result := nil; end; procedure TSyntCollection.Loaded; var i: integer; begin for i := 0 to Count - 1 do Items[i].Loaded; end; procedure TSyntCollection.Update(Item: TCollectionItem); begin inherited; if Assigned(FOnChange) then FOnChange(Self, TSyntCollectionItem(Item)); end; function TSyntCollection.ValidItem(Item: TSyntCollectionItem): Boolean; var i: integer; begin Result := True; if Item <> nil then for i := 0 to Count - 1 do if Items[i] = Item then Exit; Result := False; end; { TecSyntaxFormat } constructor TecSyntaxFormat.Create(Collection: TCollection); var i: integer; begin FIsBlock := False; FFont := TFont.Create; FFont.Name := 'Courier New'; FFont.Size := 10; FBgColor := clNone; FVertAlign := vaCenter; FFormatType := ftFontAttr; for i := 0 to 3 do begin FBorderTypes[i] := blNone; FBorderColors[i] := clBlack; end; FFormatFlags := [ffBold, ffItalic, ffUnderline, ffStrikeOut, ffReadOnly, ffHidden, ffFontName, ffFontSize, ffFontCharset, ffVertAlign]; inherited; FFont.OnChange := FontChanged; end; destructor TecSyntaxFormat.Destroy; begin FreeAndNil(FFont); inherited; end; procedure TecSyntaxFormat.AssignTo(Dest: TPersistent); var i: integer; begin inherited; if Dest is TecSyntaxFormat then with Dest as TecSyntaxFormat do begin FBgColor := Self.BgColor; FFont.Assign(Self.Font); FVertAlign := Self.FVertAlign; FIsBlock := Self.FIsBlock; FFormatType := Self.FFormatType; Hidden := Self.Hidden; ReadOnly := Self.ReadOnly; MultiLineBorder := Self.MultiLineBorder; FChangeCase := Self.ChangeCase; for i := 0 to 3 do begin FBorderTypes[i] := Self.FBorderTypes[i]; FBorderColors[i] := Self.FBorderColors[i]; end; FFormatFlags := Self.FFormatFlags; end; end; procedure TecSyntaxFormat.SetBgColor(const Value: TColor); begin FBgColor := Value; Change; end; procedure TecSyntaxFormat.SetFont(const Value: TFont); begin FFont.Assign(Value); Change; end; procedure TecSyntaxFormat.FontChanged(Sender: TObject); begin Change; end; procedure TecSyntaxFormat.SetVertAlign(const Value: TecVertAlignment); begin FVertAlign := Value; Change; end; function TecSyntaxFormat.GetItemBaseName: string; begin Result := 'Style'; end; procedure TecSyntaxFormat.SetFormatType(const Value: TecFormatType); begin FFormatType := Value; Change; end; procedure TecSyntaxFormat.Change; begin Changed(False); if Assigned(FOnChange) then FOnChange(Self); end; procedure TecSyntaxFormat.SetHidden(const Value: Boolean); begin FHidden := Value; Change; end; function TecSyntaxFormat.GetBorderColor(Index: Integer): TColor; begin if (Index >= 0) and (Index <= 3) then Result := FBorderColors[Index] else Result := clBlack; end; function TecSyntaxFormat.GetBorderType(Index: Integer): TecBorderLineType; begin if (Index >= 0) and (Index <= 3) then Result := FBorderTypes[Index] else Result := blNone; end; procedure TecSyntaxFormat.SetBorderColor(Index: Integer; const Value: TColor); begin if (Index >= 0) and (Index <= 3) then begin FBorderColors[Index] := Value; Change; end; end; procedure TecSyntaxFormat.SetBorderType(Index: Integer; const Value: TecBorderLineType); begin if (Index >= 0) and (Index <= 3) then begin FBorderTypes[Index] := Value; Change; end; end; procedure TecSyntaxFormat.SetMultiLineBorder(const Value: Boolean); begin FMultiLineBorder := Value; Change; end; procedure TecSyntaxFormat.SetReadOnly(const Value: Boolean); begin FReadOnly := Value; Change; end; procedure TecSyntaxFormat.SetChangeCase(const Value: TecChangeCase); begin FChangeCase := Value; Change; end; function TecSyntaxFormat.HasBorder: Boolean; var i: integer; begin for i := 0 to 3 do if FBorderTypes[i] <> blNone then begin Result := True; Exit; end; Result := False; end; procedure TecSyntaxFormat.SetFormatFlags(const Value: TecFormatFlags); begin if FFormatFlags <> Value then begin FFormatFlags := Value; Change; end; end; procedure TecSyntaxFormat.ApplyTo(Canvas: TCanvas; AllowChangeFont: Boolean); var fs: TFontStyles; procedure SwitchFontFlag(ff: TecFormatFlag; f: TFontStyle); begin if ff in FormatFlags then if f in Font.Style then Include(fs, f) else Exclude(fs, f); end; begin if not Enabled then Exit; if BgColor <> clNone then Canvas.Brush.Color := BgColor; if FormatType = ftBackGround then Exit else begin if Font.Color <> clNone then Canvas.Font.Color := Font.Color; if FormatType <> ftColor then begin fs := Canvas.Font.Style; SwitchFontFlag(ffBold, fsBold); SwitchFontFlag(ffItalic, fsItalic); SwitchFontFlag(ffUnderline, fsUnderline); SwitchFontFlag(ffStrikeOut, fsStrikeOut); if Canvas.Font.Style <> fs then Canvas.Font.Style := fs; if (FormatType = ftCustomFont) and AllowChangeFont then begin if ffFontName in FormatFlags then Canvas.Font.Name := Font.Name; if ffFontCharset in FormatFlags then Canvas.Font.Charset := Font.Charset; if ffFontSize in FormatFlags then Canvas.Font.Size := Font.Size; end; end; end; end; function TecSyntaxFormat.IsEqual(Other: TecSyntaxFormat): Boolean; begin Result := (BgColor = Other.BgColor) and (FormatType = Other.FormatType) and (FormatFlags = Other.FormatFlags) and (Hidden = Other.Hidden) and (ReadOnly = Other.ReadOnly) and (ChangeCase = Other.ChangeCase) and (VertAlignment = Other.VertAlignment); if Result and (FormatType <> ftBackGround) then begin Result := Font.Color = Other.Font.Color; if Result and (FormatType <> ftColor) then begin Result := Font.Style = Other.Font.Style; if Result and (FormatType <> ftFontAttr) then begin Result := (not (ffFontName in FormatFlags) or (Font.Name = Other.Font.Name)) and (not (ffFontSize in FormatFlags) or (Font.Size = Other.Font.Size)) and (not (ffFontCharSet in FormatFlags) or (Font.Charset = Other.Font.Charset)); end; end; end; end; procedure TecSyntaxFormat.Merge(Over: TecSyntaxFormat); var fs: TFontStyles; procedure SwitchFontFlag(ff: TecFormatFlag; f: TFontStyle); begin if ff in Over.FormatFlags then begin Include(FFormatFlags, ff); if f in Over.Font.Style then Include(fs, f) else Exclude(fs, f); end; end; begin if ffVertAlign in Over.FormatFlags then VertAlignment := Over.VertAlignment; if ffHidden in Over.FormatFlags then Hidden := Over.Hidden; if ffReadOnly in Over.FormatFlags then ReadOnly := Over.ReadOnly; if Over.BgColor <> clNone then BgColor := Over.BgColor; if Over.ChangeCase <> ccNone then ChangeCase := Over.ChangeCase; if Over.FormatType <> ftBackGround then begin if Over.Font.Color <> clNone then Font.Color := Over.Font.Color; if Over.FormatType <> ftColor then begin fs := Font.Style; SwitchFontFlag(ffBold, fsBold); SwitchFontFlag(ffItalic, fsItalic); SwitchFontFlag(ffUnderline, fsUnderline); SwitchFontFlag(ffStrikeOut, fsStrikeOut); Font.Style := fs; if Over.FormatType <> ftFontAttr then begin if ffFontName in Over.FormatFlags then Font.Name := Over.Font.Name; if ffFontCharset in Over.FormatFlags then Font.Charset := Over.Font.Charset; if ffFontSize in Over.FormatFlags then Font.Size := Over.Font.Size; end; end; end; FormatFlags := FormatFlags + Over.FormatFlags; end; function TecSyntaxFormat.GetHidden: Boolean; begin Result := FHidden and (ffHidden in FFormatFlags); end; procedure TecSyntaxFormat.Intersect(Over: TecSyntaxFormat); begin FormatFlags := Over.FormatFlags * FormatFlags; if Over.FormatType < FormatType then FormatType := Over.FormatType; if (ffVertAlign in FormatFlags) and (VertAlignment <> Over.VertAlignment) then FormatFlags := FormatFlags - [ffVertAlign]; if (ffReadOnly in FormatFlags) and (ReadOnly <> Over.ReadOnly) then FormatFlags := FormatFlags - [ffReadOnly]; if (ffHidden in FormatFlags) and (Hidden <> Over.Hidden) then FormatFlags := FormatFlags - [ffHidden]; if Over.ChangeCase <> ChangeCase then ChangeCase := ccNone; if BgColor <> Over.BgColor then BgColor := clNone; if FormatType = ftBackGround then Exit; if Font.Color <> Over.Font.Color then Font.Color := clNone; if FormatType = ftColor then Exit; if (ffBold in FormatFlags) and ((fsBold in Font.Style) <> (fsBold in Over.Font.Style)) then FormatFlags := FormatFlags - [ffBold]; if (ffItalic in FormatFlags) and ((fsItalic in Font.Style) <> (fsItalic in Over.Font.Style)) then FormatFlags := FormatFlags - [ffItalic]; if (ffUnderline in FormatFlags) and ((fsUnderline in Font.Style) <> (fsUnderline in Over.Font.Style)) then FormatFlags := FormatFlags - [ffUnderline]; if (ffStrikeOut in FormatFlags) and ((fsStrikeOut in Font.Style) <> (fsStrikeOut in Over.Font.Style)) then FormatFlags := FormatFlags - [ffStrikeOut]; if FormatType = ftFontAttr then Exit; if (ffFontName in FormatFlags) and (not SameText(Font.Name, Over.Font.Name)) then FormatFlags := FormatFlags - [ffFontName]; if (ffFontSize in FormatFlags) and (Font.Size <> Over.Font.Size) then FormatFlags := FormatFlags - [ffFontSize]; if (ffFontCharset in FormatFlags) and (Font.Charset <> Over.Font.Charset) then FormatFlags := FormatFlags - [ffFontCharset]; end; { TecStylesCollection } function TecStylesCollection.Add: TecSyntaxFormat; begin Result := (inherited Add) as TecSyntaxFormat; end; constructor TecStylesCollection.Create; begin inherited Create(TecSyntaxFormat); end; function TecStylesCollection.GetItem(Index: integer): TecSyntaxFormat; begin Result := (inherited Items[Index]) as TecSyntaxFormat; end; function TecStylesCollection.Synchronize(Source: TecStylesCollection): integer; var j: integer; f: TecSyntaxFormat; begin Result := 0; for j := 0 to Count - 1 do begin f := TecSyntaxFormat(Source.ItemByName(Items[j].DisplayName)); if f <> nil then begin Inc(Result); Items[j].Assign(f); end; end; end; { TecSingleTagCondition } procedure TecSingleTagCondition.AssignTo(Dest: TPersistent); var dst: TecSingleTagCondition; begin if Dest is TecSingleTagCondition then begin dst := Dest as TecSingleTagCondition; dst.CondType := CondType; dst.TokenTypes := TokenTypes; dst.FTagList.Assign(FTagList); dst.IgnoreCase := IgnoreCase; end; end; function TecSingleTagCondition.CheckToken(const Source: ecString; Token: TecSyntToken): Boolean; var s: ecString; i, N: integer; RE: TecRegExpr; begin Result := False; if FTokenTypes <> 0 then begin Result := ((1 shl Token.TokenType) and FTokenTypes) <> 0; if FCondType = tcSkip then Exit; if not Result then case FCondType of tcStrictMask, tcMask, tcEqual: Exit; tcNotEqual: begin Result := True; Exit; end; end; end; if FTagList.Count > 0 then begin s := Token.GetStr(Source); s := Trim(s); //AT if FCondType in [tcMask, tcStrictMask] then begin RE := TecRegExpr.Create; SetDefaultModifiers(RE); try for i := 0 to FTagList.Count - 1 do begin RE.Expression := FTagList[i]; if FCondType = tcMask then Result := RE.MatchLength(s, 1) > 0 else begin N := 1; Result := RE.Match(s, N); if Result then Result := N > Length(S); end; if Result then break; end; except end; FreeAndNil(RE); end else begin Result := FTagList.IndexOf(s) <> -1; if FCondType = tcNotEqual then Result := not Result; end; end else Result := FCondType <> tcNotEqual; end; constructor TecSingleTagCondition.Create(Collection: TCollection); begin inherited; FCondType := tcEqual; FTagList := TzStringList.Create; TzStringList(FTagList).Sorted := true; TzStringList(FTagList).Delimiter := ' '; TzStringList(FTagList).Duplicates := dupIgnore; TzStringList(FTagList).CaseSensitive := True; TzStringList(FTagList).OnChange := TagListChanged; {$IFDEF EC_VCL6_UP} TzStringList(FTagList).QuoteChar := ' '; {$ENDIF} end; destructor TecSingleTagCondition.Destroy; begin FreeAndNil(FTagList); inherited; end; procedure TecSingleTagCondition.SetIgnoreCase(const Value: Boolean); begin TzStringList(FTagList).CaseSensitive := not Value; end; function TecSingleTagCondition.GetIgnoreCase: Boolean; begin Result := not TzStringList(FTagList).CaseSensitive; end; procedure TecSingleTagCondition.SetTagList(const Value: TStrings); begin TzStringList(FTagList).DelimitedText := Value.Text; Changed(False); end; procedure TecSingleTagCondition.SetTokenTypes(const Value: DWORD); begin FTokenTypes := Value; Changed(False); end; procedure TecSingleTagCondition.SetCondType(const Value: TecTagConditionType); begin FCondType := Value; Changed(False); end; procedure TecSingleTagCondition.TagListChanged(Sender: TObject); begin Changed(False); end; { TecConditionCollection } function TecConditionCollection.Add: TecSingleTagCondition; begin Result := (inherited Add) as TecSingleTagCondition; end; constructor TecConditionCollection.Create(AOwner: TecTagBlockCondition); begin inherited Create(TecSingleTagCondition); FOwner := AOwner; PropName := 'Conditions'; end; function TecConditionCollection.GetItem(Index: integer): TecSingleTagCondition; begin Result := (inherited Items[Index]) as TecSingleTagCondition; end; function TecConditionCollection.GetOwner: TPersistent; begin Result := FOwner; end; procedure TecConditionCollection.Update(Item: TCollectionItem); begin inherited; if Assigned(FOnChange) then FOnChange(Self); end; { TecTagBlockCondition } constructor TecTagBlockCondition.Create(Collection: TCollection); begin inherited; FConditions := TecConditionCollection.Create(Self); FConditions.OnChange := ConditionsChanged; FBlockType := btRangeStart; FLinePos := lbTop; FDisplayInTree := True; // FHighlightPos := cpBound; FTokenType := -1; FTreeItemImage := -1; FTreeGroupImage := -1; FPen := TPen.Create; FPen.OnChange := ConditionsChanged; end; procedure TecTagBlockCondition.AssignTo(Dest: TPersistent); var dst: TecTagBlockCondition; begin inherited; if Dest is TecTagBlockCondition then begin dst := Dest as TecTagBlockCondition; dst.ConditionList := ConditionList; dst.FIdentIndex := IdentIndex; dst.FLinePos := LinePos; dst.FBlockOffset := BlockOffset; dst.FBlockType := BlockType; dst.BlockEnd := BlockEnd; dst.FEndOfTextClose := FEndOfTextClose; dst.FNotCollapsed := FNotCollapsed; dst.FSameIdent := FSameIdent; dst.Highlight := Highlight; dst.InvertColors := InvertColors; dst.DisplayInTree := DisplayInTree; dst.NameFmt := NameFmt; dst.GroupFmt := GroupFmt; dst.RefToCondEnd := RefToCondEnd; dst.DynHighlight := DynHighlight; dst.HighlightPos := HighlightPos; dst.DynSelectMin := DynSelectMin; dst.CancelNextRules := CancelNextRules; dst.DrawStaple := DrawStaple; dst.GroupIndex := GroupIndex; dst.OnBlockCheck := OnBlockCheck; dst.CollapseFmt := CollapseFmt; dst.FSelfClose := SelfClose; dst.FNoEndRule := NoEndRule; dst.GrammaRuleName := GrammaRuleName; dst.TokenType := TokenType; dst.TreeItemStyle := TreeItemStyle; dst.TreeGroupStyle := TreeGroupStyle; dst.TreeItemImage := TreeItemImage; dst.TreeGroupImage := TreeGroupImage; dst.Pen := Pen; dst.UseCustomPen := UseCustomPen; dst.IgnoreAsParent := IgnoreAsParent; dst.AutoCloseText := AutoCloseText; dst.AutoCloseMode := AutoCloseMode; end; end; function TecTagBlockCondition.Check(const Source: ecString; Tags: TecClientSyntAnalyzer; N: integer; var RefIdx: integer): Boolean; var i, offs, idx, skipped, skip_cond: integer; begin Result := False; offs := CheckOffset; skipped := 0; skip_cond := 0; i := 0; while i < ConditionList.Count do begin idx := N - 1 - i - offs - skipped + skip_cond; if (ConditionList[i].CondType = tcSkip) and (i < ConditionList.Count - 1) and (ConditionList[i+1].CondType <> tcSkip) then begin inc(i); inc(skip_cond); while (idx >= 0) and not ConditionList[i].CheckToken(Source, Tags[idx]) do begin if not ConditionList[i - 1].CheckToken(Source, Tags[idx]) then Exit; dec(idx); inc(skipped); end; if idx < 0 then Exit; end; with ConditionList[i] do if (idx < 0) or not CheckToken(Source, Tags[idx]) then Exit; inc(i); end; Result := ConditionList.Count > 0; // if FRefToCondEnd then RefIdx := N - ConditionList.Count - offs - skipped + skip_cond; // else // RefIdx := N - 1 - offs; end; destructor TecTagBlockCondition.Destroy; begin FreeAndNil(FConditions); FreeAndNil(FPen); inherited; end; function TecTagBlockCondition.GetItemBaseName: string; begin Result := 'Tag block rule'; end; function TecTagBlockCondition.GetBlockEndName: string; var FSynt: TecSyntAnalyzer; begin FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if csLoading in FSynt.ComponentState then Result := FBlockEndName else if Assigned(FBlockEndCond) then Result := FBlockEndCond.DisplayName else Result := ''; end; procedure TecTagBlockCondition.SetBlockEndName(const Value: string); var FSynt: TecSyntAnalyzer; begin FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if csLoading in FSynt.ComponentState then FBlockEndName := Value else FBlockEndCond := TecTagBlockCondition(TecBlockRuleCollection(Collection).ItemByName(Value)); Changed(False); end; procedure TecTagBlockCondition.Loaded; var FSynt: TecSyntAnalyzer; begin inherited; FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if FBlockEndName <> '' then FBlockEndCond := TecTagBlockCondition(FSynt.FBlockRules.ItemByName(FBlockEndName)); if FTreeItemStyle <> '' then FTreeItemStyleObj := TecSyntaxFormat(FSynt.Formats.ItemByName(FTreeItemStyle)); if FTreeGroupStyle <> '' then FTreeGroupStyleObj := TecSyntaxFormat(FSynt.Formats.ItemByName(FTreeGroupStyle)); end; function TecTagBlockCondition.CheckOffset: integer; begin Result := 0; if FRefToCondEnd then Exit; if FIdentIndex < 0 then Result := -FIdentIndex; if (FBlockOffset < 0) and (FBlockOffset < FIdentIndex) then Result := -FBlockOffset; end; procedure TecTagBlockCondition.SetBlockType(const Value: TecTagBlockType); begin FBlockType := Value; if FBlockType in [btTagDetect, btLineBreak] then begin FBlockOffset := 0; FBlockEndCond := nil; end; Changed(False); end; procedure TecTagBlockCondition.SetConditions( const Value: TecConditionCollection); begin FConditions.Assign(Value); end; procedure TecTagBlockCondition.ConditionsChanged(Sender: TObject); begin Changed(False); end; procedure TecTagBlockCondition.SetBlockEndCond( const Value: TecTagBlockCondition); begin if FBlockEndCond <> Value then begin FBlockEndCond := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetLinePos(const Value: TecLineBreakPos); begin if FLinePos <> Value then begin FLinePos := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetIdentIndex(const Value: integer); begin if FIdentIndex <> Value then begin FIdentIndex := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetBlockOffset(const Value: integer); begin if FBlockOffset <> Value then begin FBlockOffset := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetEndOfTextClose(const Value: Boolean); begin if FEndOfTextClose <> Value then begin FEndOfTextClose := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetNotCollapsed(const Value: Boolean); begin if FNotCollapsed <> Value then begin FNotCollapsed := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetSameIdent(const Value: Boolean); begin if FSameIdent <> Value then begin FSameIdent := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetHighlight(const Value: Boolean); begin if FHighlight <> Value then begin FHighlight := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetInvertColors(const Value: Boolean); begin if FInvertColors <> Value then begin FInvertColors := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetDisplayInTree(const Value: Boolean); begin if FDisplayInTree <> Value then begin FDisplayInTree := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetCancelNextRules(const Value: Boolean); begin if FCancelNextRules <> Value then begin FCancelNextRules := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetDynHighlight( const Value: TecDynamicHighlight); begin if FDynHighlight <> Value then begin FDynHighlight := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetDynSelectMin(const Value: Boolean); begin if FDynSelectMin <> Value then begin FDynSelectMin := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetGroupFmt(const Value: ecString); begin if FGroupFmt <> Value then begin FGroupFmt := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetHighlightPos(const Value: TecHighlightPos); begin if FHighlightPos <> Value then begin FHighlightPos := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetNameFmt(const Value: ecString); begin if FNameFmt <> Value then begin FNameFmt := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetRefToCondEnd(const Value: Boolean); begin if FRefToCondEnd <> Value then begin FRefToCondEnd := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetDrawStaple(const Value: Boolean); begin if FDrawStaple <> Value then begin FDrawStaple := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetCollapseFmt(const Value: ecString); begin if FCollapseFmt <> Value then begin FCollapseFmt := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetSelfClose(const Value: Boolean); begin if FSelfClose <> Value then begin FSelfClose := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetNoEndRule(const Value: Boolean); begin if FNoEndRule <> Value then begin FNoEndRule := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetGrammaRuleName(const Value: string); begin if FGrammaRuleName <> Value then begin FGrammaRuleName := Value; FGrammaRule := TSyntCollection(Collection).SyntOwner.Gramma.ParserRuleByName(Value); end; end; procedure TecTagBlockCondition.SetTokenType(const Value: integer); begin if FTokenType <> Value then begin FTokenType := Value; Changed(False); end; end; function TecTagBlockCondition.GetTreeItemStyle: string; begin Result := ValidStyleName(FTreeItemStyle, FTreeItemStyleObj); end; procedure TecTagBlockCondition.SetTreeItemStyle(const Value: string); begin ValidSetStyle(Value, FTreeItemStyle, FTreeItemStyleObj); end; function TecTagBlockCondition.GetTreeGroupStyle: string; begin Result := ValidStyleName(FTreeGroupStyle, FTreeGroupStyleObj); end; procedure TecTagBlockCondition.SetTreeGroupStyle(const Value: string); begin ValidSetStyle(Value, FTreeGroupStyle, FTreeGroupStyleObj); end; procedure TecTagBlockCondition.SetTreeGroupImage(const Value: integer); begin if FTreeGroupImage <> Value then begin FTreeGroupImage := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetTreeItemImage(const Value: integer); begin if FTreeItemImage <> Value then begin FTreeItemImage := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetPen(const Value: TPen); begin FPen.Assign(Value); end; procedure TecTagBlockCondition.SetUseCustomPen(const Value: Boolean); begin if FUseCustomPen <> Value then begin FUseCustomPen := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetIgnoreAsParent(const Value: Boolean); begin if FIgnoreAsParent <> Value then begin FIgnoreAsParent := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetAutoCloseText(Value: ecString); begin if Value = sLineBreak then Value := ''; if FAutoCloseText <> Value then begin FAutoCloseText := Value; Changed(False); end; end; procedure TecTagBlockCondition.SetAutoCloseMode(const Value: TecAutoCloseMode); begin if FAutoCloseMode <> Value then begin FAutoCloseMode := Value; Changed(False); end; end; { TecBlockRuleCollection } function TecBlockRuleCollection.Add: TecTagBlockCondition; begin Result := inherited Add as TecTagBlockCondition; end; constructor TecBlockRuleCollection.Create; begin inherited Create(TecTagBlockCondition); end; function TecBlockRuleCollection.GetItem(Index: integer): TecTagBlockCondition; begin Result := inherited Items[Index] as TecTagBlockCondition; end; { TecTokenRule } procedure TecTokenRule.AssignTo(Dest: TPersistent); var dst: TecTokenRule; begin inherited; if Dest is TecTokenRule then begin dst := Dest as TecTokenRule; dst.FTokenType := FTokenType; dst.FRegExpr.Expression := Expression; dst.OnMatchToken := OnMatchToken; dst.ColumnFrom := ColumnFrom; dst.ColumnTo := ColumnTo; end; end; constructor TecTokenRule.Create(Collection: TCollection); begin inherited; FBlock := nil; FFormat := nil; FRegExpr := TecRegExpr.Create; SetDefaultModifiers(FRegExpr); end; destructor TecTokenRule.Destroy; begin FreeAndNil(FRegExpr); inherited; end; function TecTokenRule.GetExpression: ecString; begin Result := FRegExpr.Expression; end; function TecTokenRule.GetIsInvalid: Boolean; begin Result := FRegExpr.IsInvalid; end; function TecTokenRule.GetItemBaseName: string; begin Result := 'Token rule'; end; function TecTokenRule.Match(const Source: ecString; Pos: integer): integer; begin try Result := FRegExpr.MatchLength(Source, Pos); except Result := 0; end; end; procedure TecTokenRule.SetColumnFrom(const Value: integer); begin if FColumnFrom <> Value then begin FColumnFrom := Value; Changed(False); end; end; procedure TecTokenRule.SetColumnTo(const Value: integer); begin if FColumnTo <> Value then begin FColumnTo := Value; Changed(False); end; end; procedure TecTokenRule.SetExpression(const Value: ecString); begin try FRegExpr.Expression := Value; except Application.HandleException(Self); end; Changed(False); end; procedure TecTokenRule.SetTokenType(const Value: integer); begin if FTokenType <> Value then begin FTokenType := Value; Changed(False); end; end; { TRuleCollectionItem } function TRuleCollectionItem.ValidStyleName(const AStyleName: string; AStyle: TecSyntaxFormat): string; var FSynt: TecSyntAnalyzer; begin FSynt := TSyntCollection(Collection).SyntOwner; Result := ''; if not Assigned(FSynt) then Exit; if csLoading in FSynt.ComponentState then Result := AStyleName else if Assigned(AStyle) then Result := AStyle.DisplayName; end; function TRuleCollectionItem.ValidSetStyle(const AStyleName: string; var AStyleField: string; var AStyle: TecSyntaxFormat): string; var FSynt: TecSyntAnalyzer; begin Result := ''; FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if csLoading in FSynt.ComponentState then AStyleField := AStyleName else AStyle := TecSyntaxFormat(FSynt.FFormats.ItemByName(AStyleName)); Changed(False); end; function TRuleCollectionItem.GetStyleName: string; begin Result := ValidStyleName(FStyleName, FFormat); end; procedure TRuleCollectionItem.SetStyleName(const Value: string); begin ValidSetStyle(Value, FStyleName, FFormat); end; procedure TRuleCollectionItem.Loaded; var FSynt: TecSyntAnalyzer; begin FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if FStyleName <> '' then FFormat := TecSyntaxFormat(FSynt.FFormats.ItemByName(FStyleName)); if FBlockName <> '' then FBlock := TecTagBlockCondition(FSynt.BlockRules.ItemByName(FBlockName)); end; function TRuleCollectionItem.GetBlockName: string; var FSynt: TecSyntAnalyzer; begin FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if csLoading in FSynt.ComponentState then Result := FBlockName else if Assigned(FBlock) then Result := FBlock.DisplayName else Result := ''; end; procedure TRuleCollectionItem.SetBlockName(const Value: string); var FSynt: TecSyntAnalyzer; begin FSynt := TSyntCollection(Collection).SyntOwner; if not Assigned(FSynt) then Exit; if csLoading in FSynt.ComponentState then FBlockName := Value else begin // FBlock := TecTagBlockCondition(FSynt.BlockRules.ItemByName(Value)); FBlock := TecTagBlockCondition(FSynt.BlockRules.ItemByName(Value)); Changed(False); end; end; procedure TRuleCollectionItem.AssignTo(Dest: TPersistent); var dst: TRuleCollectionItem; begin inherited; if Dest is TRuleCollectionItem then begin dst := Dest as TRuleCollectionItem; dst.StyleName := StyleName; dst.BlockName := BlockName; dst.StrictParent := StrictParent; dst.NotParent := NotParent; dst.AlwaysEnabled := AlwaysEnabled; dst.StatesAbsent := StatesAbsent; dst.StatesAdd := StatesAdd; dst.StatesRemove := StatesRemove; dst.StatesPresent := StatesPresent; end; end; procedure TRuleCollectionItem.SetNotParent(const Value: Boolean); begin if FNotParent <> Value then begin FNotParent := Value; Changed(False); end; end; procedure TRuleCollectionItem.SetStrictParent(const Value: Boolean); begin if FStrictParent <> Value then begin FStrictParent := Value; Changed(False); end; end; procedure TRuleCollectionItem.SetAlwaysEnabled(const Value: Boolean); begin if FAlwaysEnabled <> Value then begin FAlwaysEnabled := Value; Changed(False); end; end; function TRuleCollectionItem.GetSyntOwner: TecSyntAnalyzer; begin Result := TSyntCollection(Collection).SyntOwner; end; procedure TRuleCollectionItem.SetStatesAdd(const Value: integer); begin if FStatesAdd <> Value then begin FStatesAdd := Value; Changed(False); end; end; procedure TRuleCollectionItem.SetStatesAbsent(const Value: integer); begin if FStatesAbsent <> Value then begin FStatesAbsent := Value; Changed(False); end; end; procedure TRuleCollectionItem.SetStatesRemove(const Value: integer); begin if FStatesRemove <> Value then begin FStatesRemove := Value; Changed(False); end; end; procedure TRuleCollectionItem.SetStatesPresent(const Value: integer); begin if FStatesPresent <> Value then begin FStatesPresent := Value; Changed(False); end; end; { TecTokenRuleCollection } function TecTokenRuleCollection.Add: TecTokenRule; begin Result := inherited Add as TecTokenRule; end; constructor TecTokenRuleCollection.Create; begin inherited Create(TecTokenRule); end; function TecTokenRuleCollection.GetItem(Index: integer): TecTokenRule; begin Result := inherited Items[Index] as TecTokenRule; end; { TecParserResults } constructor TecParserResults.Create(AOwner: TecSyntAnalyzer; SrcProc: TATStringBuffer; const AClient: IecSyntClient); begin inherited Create; if SrcProc = nil then raise Exception.Create('Source procedure not passed from syntax server'); FOwner := AOwner; FSrcProc := SrcProc; FClient := AClient; FTagList := TRangeList.Create(False); FSubLexerBlocks := TObjectList.Create; FOwner.FClientList.Add(Self); FCurState := 0; FStateChanges := TObjectList.Create; end; destructor TecParserResults.Destroy; begin FOwner.FClientList.Remove(Self); FreeAndNil(FTagList); FreeAndNil(FSubLexerBlocks); FreeAndNil(FStateChanges); inherited; end; procedure TecParserResults.Clear; begin FTagList.Clear; FSubLexerBlocks.Clear; FStateChanges.Clear; FCurState := 0; end; procedure TecParserResults.Finished; //var i: integer; begin // if FFinished then Exit; FFinished := True; // Performs Gramma parsing // AnalyzeGramma; end; function TecParserResults.IsEnabled(Rule: TRuleCollectionItem; OnlyGlobal: Boolean): Boolean; begin Result := Rule.Enabled and (not OnlyGlobal or Rule.AlwaysEnabled) and ((Rule.StatesPresent = 0) or ((FCurState and Rule.StatesPresent) = Rule.StatesPresent)) and ((Rule.StatesAbsent = 0) or ((FCurState and Rule.StatesAbsent) = 0)); end; function TecParserResults.GetTokenCount: integer; begin Result := FTagList.Count; end; function TecParserResults.GetTags(Index: integer): TecSyntToken; begin Result := TecSyntToken(FTagList[Index]); end; function TecParserResults.GetTokenStr(Index: integer): ecString; begin if (Index>=0) and (Index Result then Result := FLastAnalPos; end; procedure TecParserResults.SaveState; var b: Boolean; begin if FStateChanges.Count = 0 then b := FCurState <> 0 else b := FCurState <> TRange(FStateChanges.Last).EndPos; if b then FStateChanges.Add(TRange.Create(FTagList.Count, FCurState)); end; // True if end of the text function TecParserResults.ExtractTag(const Source: ecString; var FPos: integer; IsIdle: Boolean): Boolean; var N: integer; p: TecSyntToken; own: TecSyntAnalyzer; // Select current lexer procedure GetOwner; var i, N: integer; begin own := FOwner; for i := FSubLexerBlocks.Count - 1 downto 0 do with TecSubLexerRange(FSubLexerBlocks[i]) do if FPos > StartPos then if EndPos = -1 then begin // try close sub lexer // if Rule.ToTextEnd then N := 0 else N := Rule.MatchEnd(Source, FPos); if N > 0 then begin if Rule.IncludeBounds then begin // New mode in v2.35 FEndPos := FPos - 1 + N; FCondEndPos := FEndPos; own := Rule.SyntAnalyzer; end else begin FEndPos := FPos - 1; FCondEndPos := FEndPos + N; end; // Close ranges which belongs to this sub-lexer range CloseAtEnd(FTagList.PriorAt(StartPos)); end else begin own := Rule.SyntAnalyzer; Exit; end; end else if FPos < EndPos then begin own := Rule.SyntAnalyzer; Exit; end; end; procedure CheckIntersect; var i: integer; begin for i := FSubLexerBlocks.Count - 1 downto 0 do with TecSubLexerRange(FSubLexerBlocks[i]) do if (p.EndPos > StartPos) and (p.StartPos < StartPos) then begin p.FEndPos := StartPos; Exit; end; end; function CanOpen(Rule: TecSubAnalyzerRule): Boolean; var N: integer; sub: TecSubLexerRange; begin Result := IsEnabled(Rule, False) and (Rule.SyntAnalyzer <> nil); if not Result then Exit; Result := Rule.FromTextBegin and (FPos = 1); if Result then N := 0 else N := Rule.MatchStart(Source, FPos); Result := Result or (N > 0); if not Result then Exit; // To prevent repeated opening if FSubLexerBlocks.Count > 0 then if (TecSubLexerRange(FSubLexerBlocks.Last).EndPos = FPos - 1) and (TecSubLexerRange(FSubLexerBlocks.Last).Rule = Rule) then Exit; ApplyStates(Rule); sub := TecSubLexerRange.Create(0,0); sub.FRule := Rule; sub.FCondStartPos := FPos - 1; if Rule.IncludeBounds then sub.FStartPos := FPos - 1 else sub.FStartPos := FPos + N - 1; sub.FEndPos := -1; sub.FCondEndPos := -1; FSubLexerBlocks.Add(sub); end; procedure TryOpenSubLexer; var i: integer; begin for i := 0 to own.SubAnalyzers.Count - 1 do if CanOpen(own.SubAnalyzers[i]) then Exit; if own <> FOwner then for i := 0 to FOwner.SubAnalyzers.Count - 1 do if FOwner.SubAnalyzers[i].AlwaysEnabled and CanOpen(FOwner.SubAnalyzers[i]) then Exit; end; begin GetOwner; TryOpenSubLexer; if own.SkipSpaces then begin if own.ParseEndOfLine then N := SkipSpacesNoLineBreak(Source, FPos) else N := SkipSpaces(Source, FPos); end else if FPos > Length(Source) then N := -1 else N := 0; TryOpenSubLexer; GetOwner; Result := N = -1; if Result then Exit; p := FOwner.GetToken(Self, Source, FPos, own <> FOwner); if (own <> FOwner) and (p = nil) then p := own.GetToken(Self, Source, FPos, False); if p = nil then // no token begin Inc(FPos); end else begin CheckIntersect; SaveState; FTagList.Add(p); if not FOwner.SeparateBlockAnalysis then begin FOwner.SelectTokenFormat(Self, Source, own <> FOwner); if own <> FOwner then own.SelectTokenFormat(Self, Source, False); end else // if not IsIdle then begin // Only for first iteration of analysis FOwner.HighlightKeywords(Self, Source, own <> FOwner); if own <> FOwner then own.HighlightKeywords(Self, Source, False); end; FPos := p.EndPos + 1; end; FLastAnalPos := FPos; end; function TecParserResults.AnalyzerAtPos(Pos: integer): TecSyntAnalyzer; var i: integer; begin Result := FOwner; if Pos >= 0 then for i := 0 to FSubLexerBlocks.Count - 1 do with TecSubLexerRange(FSubLexerBlocks[i]) do if Pos < StartPos then Break else if (EndPos = -1) or (Pos < EndPos) then Result := Rule.SyntAnalyzer; end; function TecParserResults.GetSubLexerRangeCount: integer; begin Result := FSubLexerBlocks.Count; end; function TecParserResults.GetSubLexerRange(Index: integer): TecSubLexerRange; begin Result := TecSubLexerRange(FSubLexerBlocks[Index]); end; function TecParserResults.GetTokenType(Index: integer): integer; begin Result := Tags[Index].TokenType; end; type TTextChangeInfo = class FPos: integer; FCount: integer; public constructor Create(Pos, Count: integer); end; constructor TTextChangeInfo.Create(Pos, Count: integer); begin inherited Create; FPos := Pos; FCount := Count; end; procedure TecParserResults.ApplyStates(Rule: TRuleCollectionItem); begin if Rule.StatesRemove <> 0 then FCurState := FCurState and not Rule.StatesRemove; if Rule.StatesAdd <> 0 then FCurState := FCurState or Rule.StatesAdd; end; procedure TecParserResults.RestoreState; var i: integer; begin for i := FStateChanges.Count - 1 downto 0 do if TRange(FStateChanges.Last).StartPos >= TagCount then FStateChanges.Delete(FStateChanges.Count - 1) else Break; if FStateChanges.Count > 0 then FCurState := TRange(FStateChanges.Last).EndPos else FCurState := 0; end; function TecParserResults.ParserStateAtPos(TokenIndex: integer): integer; var i: integer; begin for i := FStateChanges.Count - 1 downto 0 do if TRange(FStateChanges[i]).StartPos <= TokenIndex then begin Result := TRange(FStateChanges[i]).EndPos; Exit; end; Result := 0; end; { TecChangeFixer } constructor TecChangeFixer.Create; begin inherited Create; FList := TObjectList.Create; end; destructor TecChangeFixer.Destroy; begin FreeAndNil(FList); inherited; end; procedure TecChangeFixer.Clear; begin FList.Clear; end; procedure TecChangeFixer.Add(Pos, Count: integer); begin FList.Add(TTextChangeInfo.Create(Pos, Count)); end; function TecChangeFixer.CurToOld(CurPos: integer): integer; var i: integer; begin for i := FList.Count - 1 downto 0 do with TTextChangeInfo(FList[i]) do if CurPos > FPos then if (FCount > 0) and (FPos + FCount > CurPos) then CurPos := FPos else Dec(CurPos, FCount); Result := CurPos; end; function TecChangeFixer.OldToCur(OldPos: integer): integer; var i: integer; begin for i := 0 to FList.Count - 1 do with TTextChangeInfo(FList[i]) do if OldPos >= FPos then if (FCount < 0) and (FPos - FCount > OldPos) then OldPos := FPos else Inc(OldPos, FCount); Result := OldPos; end; function TecChangeFixer.UpOldNoChange: integer; var i, t: integer; begin Result := 0; for i := 0 to FList.Count - 1 do with TTextChangeInfo(FList[i]) do begin if FPos < Result then if (FCount < 0) and (FPos - FCount > Result) then Result := FPos else Inc(Result, FCount); if FCount > 0 then t := FPos + FCount else t := FPos; if Result < t then Result := t; end; end; { TecClientSyntAnalyzer } constructor TecClientSyntAnalyzer.Create(AOwner: TecSyntAnalyzer; SrcProc: TATStringBuffer; const AClient: IecSyntClient); begin // FFinishEvent := TEvent.Create(nil, True, False, ''); FDataAccess := TCriticalSection.Create; inherited Create( AOwner, SrcProc, AClient); FRanges := TSortedList.Create(True); FLineBreaks := TObjectList.Create; FOpenedBlocks := TSortedList.Create(False); FChanges := TecChangeFixer.Create; FSavedTags := TRangeList.Create; FLineBreakRanges := TRangeCollection.Create; FIdleTimer := TTimer.Create(nil); FIdleTimer.OnTimer := IntIdleAppend; FIdleTimer.Enabled := False; FIdleTimer.Interval := 100; IdleAppend; end; destructor TecClientSyntAnalyzer.Destroy; begin SafeDestroying(Self); if Assigned(FIdleTimer) then FIdleTimer.Enabled := False; FreeAndNil(FIdleTimer); FreeAndNil(FChanges); FreeAndNil(FSavedTags); FreeAndNil(FLineBreakRanges); FreeAndNil(FRanges); FreeAndNil(FLineBreaks); FreeAndNil(FOpenedBlocks); FreeAndNil(FDataAccess); inherited; end; procedure TecClientSyntAnalyzer.Clear; begin Lock; try inherited; FRepeateAnalysis := False; FTagList.Clear; FRanges.Clear; FLineBreaks.Clear; FOpenedBlocks.Clear; FChanges.Clear; FSavedTags.Clear; FLineBreakRanges.Clear; FFinished := False; FBreakIdle := True; FLastAnalPos := 0; FStartSepRangeAnal := 0; finally Unlock; end; IdleAppend; end; procedure TecClientSyntAnalyzer.AddRange(Range: TecTextRange); begin Range.FIndex := FRanges.Count; FRanges.Add(Range); if FOpenedBlocks.Count > 0 then Range.FParent := TecTextRange(FOpenedBlocks[FOpenedBlocks.Count - 1]); if Range.FEnd = -1 then FOpenedBlocks.Add(Range); end; function IndentOf(const S: ecString): Integer; var i: Integer; begin Result:= 0; for i:= 1 to Length(S) do case S[i] of ' ': Inc(Result); #9: Inc(Result, 4); else Break; end; end; function TecClientSyntAnalyzer.CloseRange(Cond: TecTagBlockCondition; RefTag: integer): Boolean; var j: integer; b: boolean; begin for j := FOpenedBlocks.Count - 1 downto 0 do with TecTextRange(FOpenedBlocks[j]) do if Assigned(FRule) then begin if Cond.BlockType = btRangeStart then b := Cond.SelfClose and (FRule = Cond) else b := (FRule.FBlockEndCond = Cond) or (FRule = Cond.FBlockEndCond); if b then begin if Cond.SameIdent and not SameText(TagStr[RefTag - Cond.IdentIndex] , TagStr[FIdent]) then Continue; FEnd := RefTag - Cond.BlockOffset; if (FRule = Cond) and (FEnd > 0) then Dec(FEnd); // for self closing FEndCondIndex := RefTag; if Assigned(Owner.OnCloseTextRange) then Owner.OnCloseTextRange(Self, TecTextRange(FOpenedBlocks[j]), FStart, FEnd); FOpenedBlocks.Delete(j); Result := True; Exit; end; end; Result := False; end; function TecClientSyntAnalyzer.HasOpened(Rule: TRuleCollectionItem; Parent: TecTagBlockCondition; Strict: Boolean): Boolean; var i: integer; prn: TecTagBlockCondition; begin if Strict then begin if FOpenedBlocks.Count > 0 then begin i := FOpenedBlocks.Count - 1; prn := TecTextRange(FOpenedBlocks[i]).Rule; if (Rule is TecTagBlockCondition) and TecTagBlockCondition(Rule).SelfClose and (prn = Rule) then Dec(i); repeat if i < 0 then begin Result := False; Exit; end; prn := TecTextRange(FOpenedBlocks[i]).Rule; Dec(i); until not prn.IgnoreAsParent; Result := prn = Parent; end else Result := Parent = nil; end else begin Result := True; if Parent = nil then Exit; for i := FOpenedBlocks.Count - 1 downto 0 do if TecTextRange(FOpenedBlocks[i]).Rule = Parent then Exit; Result := False; end; end; procedure TecClientSyntAnalyzer.Finished; var i: integer; begin if FFinished then Exit; inherited Finished; // Close SubLexers at the End of Text for i := FSubLexerBlocks.Count - 1 downto 0 do with TecSubLexerRange(FSubLexerBlocks[i]) do if (EndPos = -1) and Rule.ToTextEnd then begin FEndPos := FSrcProc.TextLength{ - 1}; FCondEndPos := FEndPos; end; // Close blocks at the end of text CloseAtEnd(0); FRepeateAnalysis := True; end; procedure TecClientSyntAnalyzer.IntIdleAppend(Sender: TObject); var FPos, tmp, i: integer; own: TecSyntAnalyzer; begin if FIdleProc or FDisableIdleAppend then Exit; FIdleTimer.Enabled := False; FBreakIdle := False; FIdleProc := True; FPos := 0; try while not FBreakIdle and not FFinished do begin tmp := GetLastPos(FSrcProc.FText); if tmp > FPos then FPos := tmp; if ExtractTag(FSrcProc.FText, FPos, True) then begin if FOwner.SeparateBlockAnalysis then for i := FStartSepRangeAnal + 1 to TagCount do begin own := Tags[i - 1].Rule.SyntOwner; FOwner.SelectTokenFormat(Self, FSrcProc.FText, own <> FOwner, i); if own <> FOwner then own.SelectTokenFormat(Self, FSrcProc.FText, False, i); if SafeProcessMessages(Self) <> 0 then Exit; // Exit if analyzer is destroyed after processing messages if FBreakIdle then begin FIdleProc := False; Exit; // Exit when breaking end; end; Finished; // Exit; end else begin if SafeProcessMessages(Self) <> 0 then Exit; // Exit if analyzer is destroyed after processing messages end; end; except //MessageBox(0, 'Error while idle', 'Error', MB_OK); end; FIdleProc := False; end; procedure TecClientSyntAnalyzer.IdleAppend; begin if not FFinished then begin FIdleTimer.Enabled := False; if FRepeateAnalysis then FIdleTimer.Interval := Owner.IdleAppendDelay else FIdleTimer.Interval := Owner.IdleAppendDelayInit; FIdleTimer.Enabled := True; end; end; procedure TecClientSyntAnalyzer.AppendToPos(APos: integer); var FPos: integer; begin if Length(FSrcProc.FText) = 0 then Exit; if FFinished then Exit; FPos := GetLastPos(FSrcProc.FText); while FPos - 1 <= APos + 1 do begin if ExtractTag(FSrcProc.FText, FPos, False) then begin if not FOwner.SeparateBlockAnalysis then Finished else if not FIdleProc then IdleAppend; //IntIdleAppend(nil) Break; end; end; end; procedure TecClientSyntAnalyzer.TryAppend(APos: integer); var sPos, sPos1: integer; begin if FSavedTags.Count = 0 then AppendToPos(APos) else begin sPos1 := FChanges.OldToCur(TecSyntToken(FSavedTags[0]).StartPos); sPos := FChanges.UpOldNoChange;// + 1; if sPos1 > sPos then sPos := sPos1; if (sPos <> 0) and (sPos < APos) then AppendToPos(sPos) else AppendToPos(APos); end; end; procedure TecClientSyntAnalyzer.ChangedAtPos(APos: integer); var i, N: integer; procedure CleanRangeList(List: TSortedList; IsClosed: Boolean); var i: integer; begin for i := List.Count - 1 downto 0 do with TecTextRange(List[i]) do if (FCondIndex >= N) or (FStart >= N) or IsClosed and ((FEndCondIndex >= N) or (FEnd >= N)) then List.Delete(i); end; begin { if FSrcProc.TextLength <= Owner.FullRefreshSize then begin Clear; Exit; end;} Lock; try FFinished := False; Dec(APos); FBreakIdle := True; FIdleTimer.Enabled := False; if FSrcProc.TextLength <= Owner.FullRefreshSize then begin APos := 0; end else if Owner.RestartFromLineStart then begin N := FSrcProc.StrToCaret(APos + 1).Y; APos := min(APos, FSrcProc.CaretToStr(Classes.Point(0, N))); end; // Check sub lexer ranges for i := FSubLexerBlocks.Count - 1 downto 0 do with TecSubLexerRange(FSubLexerBlocks[i]) do if APos < StartPos then begin if APos > CondStartPos then APos := CondStartPos; FSubLexerBlocks.Delete(i); // remove sub lexer end else if APos < CondEndPos then begin if APos > EndPos then APos := EndPos; FEndPos := -1; // open sub lexer FCondEndPos := -1; end; // Remove tokens if FSavedTags.Count = 0 then FTagList.ClearFromPos(APos, FSavedTags) else FTagList.ClearFromPos(APos); FLastAnalPos := 0; // Reset current position N := FTagList.Count; FStartSepRangeAnal := N; // Remove text ranges from service containers CleanRangeList(FOpenedBlocks, False); // Remove text ranges from main storage for i := FRanges.Count - 1 downto 0 do with TecTextRange(FRanges[i]) do if (FCondIndex >= N) or (FStart >= N) then FRanges.Delete(i) else if (FEndCondIndex >= N) or (FEnd >= N) then begin FEnd := -1; FEndCondIndex := -1; FOpenedBlocks.Add(FRanges[i]); end; // Remove separators for i := FLineBreaks.Count - 1 downto 0 do if TecLineBreak(FLineBreaks[i]).RefIdx >= N then FLineBreaks.Delete(i); // Restore parser state RestoreState; finally Unlock; end; IdleAppend; end; function TecClientSyntAnalyzer.TokenAtPos(Pos: integer): integer; begin AppendToPos(Pos); Result := FTagList.RangeAt(Pos); end; function TecClientSyntAnalyzer.PriorTokenAt(Pos: integer): integer; begin Result := FTagList.PriorAt(Pos); end; procedure TecClientSyntAnalyzer.AddLineBreak(lb: TecLineBreak); begin FLineBreaks.Add(lb); end; function TecClientSyntAnalyzer.GetRangeBound(Range: TecTextRange): TPoint; begin Result.X := TecSyntToken(FTagList[Range.FStart]).StartPos; if Range.FEnd = - 1 then Result.Y := Result.X else Result.Y := TecSyntToken(FTagList[Range.FEnd]).EndPos; end; function TecClientSyntAnalyzer.GetColRangeBound(Range: TecTextRange): TPoint; var sIdx, eIdx: integer; begin sIdx := Range.StartIdx; eIdx := Range.EndIdx; if Assigned(Owner.OnGetCollapseRange) then Owner.OnGetCollapseRange(Self, Range, sIdx, eIdx); Result.X := Tags[sIdx].StartPos; if eIdx = -1 then Result.Y := Result.X else Result.Y := Tags[eIdx].EndPos; end; function TecClientSyntAnalyzer.RangeAtPos(APos: integer): TecTextRange; begin Result := TecTextRange(FRanges.GetAt(APos)); end; function TecClientSyntAnalyzer.RangeIdxAtPos(APos: integer): integer; begin Result := FRanges.GetIndexAt(APos); end; function TecClientSyntAnalyzer.NearestRangeAtPos(APos: integer): TecTextRange; var idx: integer; begin idx := NearestRangeIdxAtPos(APos); if idx <> -1 then Result := Ranges[idx] else Result := nil; { idx := FRanges.PriorAt(APos); if idx <> -1 then for i := idx downto 0 do with TecTextRange(FRanges[i]) do if (EndIdx <> -1) and (Tags[EndIdx].EndPos >= APos) then begin Result := TecTextRange(FRanges[i]); Exit; end; Result := nil;} end; function TecClientSyntAnalyzer.NearestRangeIdxAtPos(APos: integer): integer; begin Result := FRanges.PriorAt(APos); if Result <> -1 then while Result >= 0 do with TecTextRange(FRanges[Result]) do if (EndIdx <> -1) and (Tags[EndIdx].EndPos >= APos) then Exit else Dec(Result); end; function TecClientSyntAnalyzer.GetRangeCount: integer; begin Result := FRanges.Count; end; function TecClientSyntAnalyzer.GetRanges(Index: integer): TecTextRange; begin Result := TecTextRange(FRanges[Index]); end; procedure TecClientSyntAnalyzer.Analyze(ResetContent: Boolean); var OldSep: integer; begin if IsFinished then Exit; if ResetContent then begin OldSep := FOwner.FSeparateBlocks; FOwner.FSeparateBlocks := 2; // disanle separation analysis Clear; AppendToPos(Length(FSrcProc.FText)); FOwner.FSeparateBlocks := OldSep; end else begin AppendToPos(Length(FSrcProc.FText)); end; end; procedure TecClientSyntAnalyzer.CompleteAnalysis; var own: TecSyntAnalyzer; i: integer; begin AppendToPos(Length(FSrcProc.FText)); if FOwner.SeparateBlockAnalysis then for i := FStartSepRangeAnal + 1 to TagCount do begin own := Tags[i - 1].Rule.SyntOwner; FOwner.SelectTokenFormat(Self, FSrcProc.FText, own <> FOwner, i); if own <> FOwner then own.SelectTokenFormat(Self, FSrcProc.FText, False, i); FBreakIdle := True; Finished; end; end; function TecClientSyntAnalyzer.RangeFormat(const FmtStr: ecString; Range: TecTextRange): ecString; var i, j, idx, N, to_idx: integer; rng: TecTextRange; LineMode: integer; { HAW: hans@werschner.de [Oct'07] ......... additions to formatting token parts ...... I have added syntax to each single ".... %xyz ...." clause processing a) %(S|E)P*(L|Z)?[0-9]+ may be expanded to %(S|E)P*([\[][\]]?)? where is a specific token that is "searched from the specified starting point (S for first token in the range , or E for the last token) towards the respective range end (up- or downwards). The search-direction is kept in the variable "rngdir" which is set in the "S" , "E" decision. example: line(s) is/are ".... for x = 1 to 12 do ...... end ; ..." 0 1 2 3 4 5 6 ... 27 28 range-start = "for", range-end = "end" then "...%s[to] ..." will skip forward to the token "to" (with index 4). The token values are searched on a "asis" basis, there is no case-insensitivity option yet. A "numeric number following the token value will define an relative to the found token. For this clause, the variable "idx" is not set by taking the static numeric value as in "...%s2 ..." , instead the "found token index" is kept. For "%S..." the search starts at idx=0 up to max 28. ---> rngdir = +1; For "%E..." the search starts at idx=28 downto min 0. ---> rngdir = -1; The options L or Z introduced in V2.35 will not combine with the new (range) specifying options --> somebody else may find a use for such extended ranges. Notes: Avoid to search for tokens that can occur at multiple places (for example a ";" between statements). The above syntax is simple as it allows to identify the block-start-tokens "for x = 1 to 12 do" block-body anything after block-start tokens up to block-end-tokens "end ;" but many syntax formats do not trivially support this separation. The current implementation does not provide the information where "block-start", "block-body" and "block-end" are beginning/ending. A "%B0..." for the "block-body" portion and a "ignore block-body tokens" option may be nice !? b) any such clause (either absolute or given by token value) can "start a token range" by additionally specifying: %(S|E)...~(S|E)P*[0-9]+ or %(S|E)...~(S|E)P*([\[][\]]?)? or %(S|E)...~[\[][\]] The first form uses the static index specification to define the end-range: "%s0~s3" results in "for x = 1" (tokens 0, 1, ... 3) The 2nd form uses the new syntax to "search for an end-token beginning at the starting range index (idx) up- or down-wards. "%s0~s[do]" results in "for x = 1 to 12 do" (tokens 0, 1, ... 6) if a search is not satisfied, the complete range up to "e0" is taken. Because of the same "S", the search starts with "TagStr[idx]" ... "s0~e[do]" results in the same string, but starts at the final "end" of the block and scanning downwards. Caution: This may produce WRONG results if nested loops are scanned ! I could not find a valid representation of "range-start" token- streams, the range-body alone and/or the range-end token-stream. Such information may be helpful to better display blocks and/or collapse display of the "block-body" alone. The 3rd form is an abbreviation where the S/E indicators are taken to be identical as the starting point "S1~[do]1" results in "x = 1 to 12" (tokens 1, 2, ... 5) The "1" will here skip back by 1 from the found token "do". The range-end is kept in the variable "to_idx". The "token-value" to search for can not be whitespace #00..#20. Leading and trailing whitespace withing the "...[vvvvvvv] ..." enclosed by [ and ] characters sequence is removed before searching. the "vvvvvv" can contain escaped characters like "... [\]] ..." to allow "[" and/or "]" to be part of the value. The \r, \n, \f ...escapes are not supported here. The token accumulation simply (?) takes all tokens from "idx" ... "to_idx" and builds a string by appending all tokens with ONE " " (blank) as separating delimiter. There is no process to keep the original token positions within the source line(s) and any whitepace including cr/lf's there. This may be an addition but I currently do not see a need for it. c) "ranges as specified above may accumulate many tokens and it may be desirable to "limit" the result string. This can be done by using another operand syntax %(S|E)...~[0-9]+ or %(S|E)...~(S|E)([\[][\]]?)?~[0-9]+ or %(S|E)...~[\[][\]]~[0-9]+ In all three forms the "~" is immediately followed by a numeric value which is interpreted as "maximum number of tokens in the substituted string", if the range takes MORE than this maximum The value is internally kept in the variable "rngmax" below. When the result string is accumulated (taking all tokens between "idx" up- resp. down-to "to_idx") the number of appended tokens can not go beyond "rngmax". If this happens the result will be created in the form "t-1 t-2 -- t-max ..." with the ellipsis string " ..." appended. d) There is another addition to the token clause syntax which is NOT YET operational: I am not too happy that the collapsed string displayed is completely in "grey" colour. As I want to have some control over "highlighting" in this string also, I tried to add some style-reference information to the token clause. *** I currently do not yet understand HOW to activate such a style within the results of this formatting, but I will TRY !! OK, the added syntax for styles for future use ;-) .... %: