{******************************************} { } { FastReport VCL } { Syntax memo control } { } { Copyright (c) 1998-2021 } { by Fast Reports Inc. } { } {******************************************} unit frxSynMemo; interface {$I frx.inc} uses {$IFNDEF FPC}Windows, Messages, Imm,{$ENDIF} Types, SysUtils, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Forms, frxCtrls, fs_iparser, frxPopupForm, fs_xml, fs_iinterpreter, Menus, frxRes, frxHint {$IFDEF FPC} ,LCLType, LMessages, LazHelper, LCLIntf, LCLProc {$ENDIF}; const WM_FRX_SYNC_SCRIPT = WM_USER + 100; WM_FRX_UPDATE_CODE = WM_USER + 101; WM_FRX_FILL_CODE_COMPLETION = WM_USER + 102; type TfrxCompletionList = class; TCharAttr = (caNo, caText, caComment, caKeyword, caString, caNumber); //TCharAttributes = set of TCharAttr; TfrxCharAttributes = record StyleIndex: Byte; IsSelBlock: Boolean; end; TfrxAttributeStyle = class(TCollectionItem) private FStyleID: Byte; FFontColor: TColor; FFontStyle: TFontStyles; FKeywords: TStrings; FAttrType: TCharAttr; protected procedure SetCollection(Value: TCollection); override; public constructor Create(Collection: TCollection); override; destructor Destroy; override; property StyleID: Byte read FStyleID; published property AttrType: TCharAttr read FAttrType write FAttrType; property FontColor: TColor read FFontColor write FFontColor; property FontStyle: TFontStyles read FFontStyle write FFontStyle; property Keywords: TStrings read FKeywords; end; TfrxAttributeStyles = class(TCollection) private { null object } FDefaultAttribute: TfrxAttributeStyle; FIndexedList: TStringList; function GetItem(Index: Integer): TfrxAttributeStyle; public function GetUniqueID: Byte; constructor Create; destructor Destroy; override; function Add: TfrxAttributeStyle; function GetStyleByID(ID: Byte): TfrxAttributeStyle; procedure AssignStyleByID(ID: Byte; aFont: TFont); procedure AssignStyle(aStyle: TfrxAttributeStyle; aFont: TFont); function FindStyleIDByKeyword(const Name: String; AttrType: TCharAttr): Byte; property Items[Index: Integer]: TfrxAttributeStyle read GetItem; default; end; TfrxSynDialectStyle = class(TPersistent) private FAttributeStyles: TfrxAttributeStyles; FKeywords: String; FCommentLine1: String; FCommentLine2: String; FCommentBlock1: String; FCommentBlock2: String; FStringQuotes: String; FHexSequence: String; FName: String; FOwner: TObject; procedure SetName(const Value: String); public constructor Create(AOwner: TObject); destructor Destroy; override; { TODO: we need one contract for all setings. I.e. need interface for this } procedure SaveTo(const Section: String; Ini: TObject); procedure LoadFrom(const Section: String; Ini: TObject); property AttributeStyles: TfrxAttributeStyles read FAttributeStyles; property Name: String read FName write SetName; published property Keywords: String read FKeywords write FKeywords; property CommentLine1: String read FCommentLine1 write FCommentLine1; property CommentLine2: String read FCommentLine2 write FCommentLine2; property CommentBlock1: String read FCommentBlock1 write FCommentBlock1; property CommentBlock2: String read FCommentBlock2 write FCommentBlock2; property StringQuotes: String read FStringQuotes write FStringQuotes; property HexSequence: String read FHexSequence write FHexSequence; end; TfrxSynDialectStyles = class(TObject) private FLIst: TList; FDefSynDialectStyle: TfrxSynDialectStyle; FActiveIndex: Integer; FActiveChanged: TNotifyEvent; function GetItem(Index: Integer): TfrxSynDialectStyle; function GetActiveDialicet: TfrxSynDialectStyle; function GetActiveStyles: TfrxAttributeStyles; procedure SetActiveIndex(const Value: Integer); public constructor Create; destructor Destroy; override; function Add: TfrxSynDialectStyle; procedure Clear; function Count: Integer; { TODO: we need one contract for all setings. I.e. need interface for this } procedure SaveTo(const Section: String; Ini: TObject); procedure LoadFrom(const Section: String; Ini: TObject); property Items[Index: Integer]: TfrxSynDialectStyle read GetItem; default; property ActiveDialicet: TfrxSynDialectStyle read GetActiveDialicet; property ActiveStyles: TfrxAttributeStyles read GetActiveStyles; property ActiveIndex: Integer read FActiveIndex write SetActiveIndex; property OnActiveChanged: TNotifyEvent read FActiveChanged write FActiveChanged; end; TfrxCodeCompletionEvent = procedure(const Name: String; List: TfrxCompletionList) of object; TfrxByteArr = array of Byte; TfrxSynAttributes = class private FArray: array of TfrxByteArr; FCapacity: Integer; FCount: Integer; FUpdating: Boolean; FDialectStyles: TfrxSynDialectStyles; FParser: TfsParser; procedure SetCapacity(NewCapacity: Integer); procedure SetCount(NewCount: Integer); function GetLine(Index: Integer): TfrxByteArr; procedure PutLine(Index: Integer; const Value: TfrxByteArr); procedure ActiveChanged(Sender: TObject); public constructor Create(Parser: TfsParser; DialectStyles: TfrxSynDialectStyles); procedure SetLineLen(Index: Integer; NewLen: Integer); procedure Delete(Index: Integer); function GetAllAttributes: TfrxByteArr; procedure SetAllAttributes(Attr: TfrxByteArr); procedure UpdateSyntax(EndLine: Integer; Text: TStringList); procedure UpdateSyntaxDialect; property Line[Index: Integer]: TfrxByteArr read GetLine write PutLine; default; property Count: Integer read FCount write SetCount; property Updating: Boolean read FUpdating; end; TfrxBreakPoint = class private FCondition: String; FSpecialCondition: String; FEnabled: Boolean; FLine: Integer; public property Condition: String read FCondition write FCondition; property Enabled: Boolean read FEnabled write FEnabled; property Line: Integer read FLine write FLine; property SpecialCondition: String read FSpecialCondition write FSpecialCondition; end; TfrxItemType = (itVar, itProcedure, itFunction, itProperty, itIndex, itConstant, itConstructor, itType, itEvent); TfrxItemTypes = set of TfrxItemType; TfrxCompletionListType = (cltRtti, cltScript, cltAddon); TfrxCompletionListTypes = set of TfrxCompletionListType; TfrxCompletionItem = class private FParent: TfrxCompletionItem; FName: String; FType: String; FParams: String; FItemType: TfrxItemType; FStartVisible: Integer; FEndVisible: Integer; public property Name: String read FName; property Typ: String read FType; property Params: String read FParams; property ItemType: TfrxItemType read FItemType; end; TfrxCompletionList = class private FConstants: TStringList; FVariables: TStringList; FFunctions: TStringList; FClasses: TStringList; FLocked: Boolean; function AddBaseVar(varList: TStrings; const Name, sType: String; VisibleStart: Integer = 0; VisibleEnd: Integer = -1; const ParentFunc: String = ''): TfrxCompletionItem; function GetItem(Index: Integer): TfrxCompletionItem; public constructor Create; destructor Destroy; override; procedure DestroyItems; function Count: Integer; function AddConstant(const Name, sType: String; VisibleStart: Integer = 0; VisibleEnd: Integer = -1; const ParentFunc: String = ''): TfrxCompletionItem; function AddVariable(const Name, sType: String; VisibleStart: Integer = 0; VisibleEnd: Integer = -1; const ParentFunc: String = ''): TfrxCompletionItem; function AddClass(const Name, sType: String; VisibleStart: Integer = 0; VisibleEnd: Integer = -1; const ParentFunc: String = ''): TfrxCompletionItem; function AddFunction(const Name, sType, Params: String; VisibleStart: Integer = 0; VisibleEnd: Integer = -1; const ParentFunc: String = ''): TfrxCompletionItem; function Find(const Name: String): TfrxCompletionItem; property Items[Index: Integer]: TfrxCompletionItem read GetItem; default; property Locked: Boolean read FLocked write FLocked; end; { TfrxCodeCompletionThread } TfrxCodeCompletionThread = class(TThread) private FText: TStringList; FScript: TfsScript; FOriginalScript: TfsScript; FILCode: TStream; FXML: TfsXMLDocument; FCompletionList: TfrxCompletionList; FSyntaxType: String; FMemoHandle: HWND; procedure SyncScript; procedure UpdateCode; procedure FreeScript; procedure FillCodeCompletion; public destructor Destroy; override; procedure Execute; override; property Script: TfsScript read FOriginalScript write FOriginalScript; end; {$IFDEF FPC} { TBrkStringList } TBrkStringList = class(TStringList) function AddObject(const S: string; AObject: TObject): Integer; override; overload; end; {$ENDIF} TfrxSyntaxMemo = class(TfrxScrollWin) private {$IFDEF NONWINFPC} FCaretCreated: Boolean; {$ENDIF} FActiveLine: Integer; FAllowLinesChange: Boolean; FBlockColor: TColor; FBlockFontColor: TColor; FBookmarks: array[0..9] of Integer; FCharHeight: Integer; FCharWidth: Integer; FCommentAttr: TFont; FCompletionForm: TfrxPopupForm; FCompletionLB: TListBox; FDoubleClicked: Boolean; FDown: Boolean; FToggleBreakPointDown: Boolean; FGutterWidth: Integer; FIsMonoType: Boolean; FKeywordAttr: TFont; FMaxLength: Integer; FMessage: String; FModified: Boolean; FMoved: Boolean; FNumberAttr: TFont; FOffset: TPoint; FOnChangePos: TNotifyEvent; FOnChangeText: TNotifyEvent; FOnCodeCompletion: TfrxCodeCompletionEvent; FParser: TfsParser; FPos: TPoint; FStringAttr: TFont; FSelEnd: TPoint; FSelStart: TPoint; FTabStops: Integer; {$IFNDEF FPC} FCompSelStart: TPoint; FCompSelEnd: TPoint; {$ENDIF} FShowGutter: boolean; //FSynStrings: TStrings; FSynAttributes: TfrxSynAttributes; FSynDialectStyles: TfrxSynDialectStyles; FSyntax: String; FTempPos, FLastHintPos: TPoint; FText: TStringList; FTextAttr: TFont; FUndo: TStringList; FWindowSize: TPoint; FBreakPoints: {$IFDEF FPC}TBrkStringList{$ELSE}TStringList{$ENDIF}; FCodeCompList: TStringList; FStartCodeCompPos: Integer; FCompleationFilter: String; FScriptRTTIXML: TfsXMLDocument; FRttiCompletionList: TfrxCompletionList; FScriptCompletionList: TfrxCompletionList; FAddonCompletionList: TfrxCompletionList; FClassCompletionList: TfrxCompletionList; FCodeCompletionThread: TfrxCodeCompletionThread; FScript: TfsScript; FTimer: TTimer; FShowLineNumber: Boolean; FCodeComplitionFilter: TfrxItemTypes; FShowInCodeComplition: TfrxCompletionListTypes; FCodeCompletionWidth: Integer; FCodeCompletionHeight: Integer; FCodeCompletionMinHeight: Integer; FCodeCompletionMinWidth: Integer; FMultiByteLang: Boolean; FfrxHintShowEvent: TfrxHintShowEvent; FEnableHint: Boolean; {$IFNDEF FPC} FTmpCanvas: TBitmap; { need for east languages carret correction } function GetCharWidth(const Str: String): Integer; function GetCharXPos(X: Integer): Integer; {$ENDIF} function GetCharAttr(Pos: TPoint): TfrxCharAttributes; function GetLineBegin(Index: Integer): Integer; function GetPlainTextPos(Pos: TPoint): Integer; function GetPosPlainText(Pos: Integer): TPoint; function GetRunLine(Index: Integer): Boolean; function GetSelText: String; function GetText: TStrings; function LineAt(Index: Integer; UseTrim: Boolean = True): String; function GetIdentEnd(aPos: Integer): Integer; function IsCursorInStringBlock: Boolean; function LineLength(Index: Integer): Integer; function Pad(n: Integer): String; procedure AddSel; procedure AddUndo; procedure ClearSel; procedure ClearSyntax(ClearFrom: Integer); procedure CompletionFormClose(Sender: TObject; var Action: TCloseAction); procedure CompletionLBDblClick(Sender: TObject); procedure CompletionLBDrawItem(Control: TWinControl; Index: Integer; ARect: TRect; State: TOwnerDrawState); function ItemToPrefix(Item: TfrxCompletionItem; var pref: String; c: TColor = clNone): TColor; procedure CompletionLBKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure CompletionLBKeyPress(Sender: TObject; var Key: Char); procedure CorrectBookmark(Line, Delta: Integer); procedure CorrectBreakPoints(Line, Delta: Integer); procedure CreateSynArray(EndLine: Integer); procedure DoBackspace; procedure DoChange; procedure DoChar(Ch: Char); procedure DoCodeCompletion; procedure BuildCClist(const sName: String; aCodeCompList: TStringList; AllFunc: Boolean = False); procedure DoCtrlI; procedure DoCtrlU; procedure DoCtrlR; procedure DoCtrlL; procedure DoDel; procedure DoDown; procedure DoEnd(Ctrl: Boolean); procedure DoHome(Ctrl: Boolean); procedure DoLeft; procedure DoPgUp; procedure DoPgDn; procedure DoReturn; procedure DoRight; procedure DoUp; procedure EnterIndent; procedure LinesChange(Sender: TObject); procedure SetActiveLine(Line: Integer); procedure SetCommentAttr(Value: TFont); procedure SetKeywordAttr(Value: TFont); procedure SetNumberAttr(const Value: TFont); procedure SetRunLine(Index: Integer; const Value: Boolean); procedure SetSelText(const Value: String); procedure SetShowGutter(Value: Boolean); procedure SetStringAttr(Value: TFont); procedure SetSyntax(const Value: String); procedure SetText(Value: TStrings); procedure SetTextAttr(Value: TFont); procedure ShiftSelected(ShiftRight: Boolean); procedure ShowCaretPos; procedure TabIndent; procedure UnIndent; procedure UpdateScrollBar; procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; { Inline IME realisation } {$IFNDEF FPC} procedure WMIMEStartComp(var Message: TMessage); message WM_IME_STARTCOMPOSITION; procedure WMIMEEndComp(var Message: TMessage); message WM_IME_ENDCOMPOSITION; procedure WMIMECOMPOSITION (var Message: TMessage); message WM_IME_COMPOSITION ; {$ENDIF} procedure WMFRXSyncScript(var Message: TMessage); message WM_FRX_SYNC_SCRIPT; procedure WMFRXUpdateCode(var Message: TMessage); message WM_FRX_UPDATE_CODE; procedure WMFRXFillCodeCompletion(var Message: TMessage); message WM_FRX_FILL_CODE_COMPLETION; procedure SetEnableHint(vEnableHint: boolean); procedure FakeHintShow(var Msg: TCMHintShow); procedure RealHintShow(var Msg: TCMHintShow); procedure WMFRXHintShow(var Msg: TCMHintShow); message CM_HINTSHOW; function OffsPoint(Point: TPoint): TPoint; procedure GetCurWord(Point: TPoint; var Prefix: String; var Header: String; var TextHint: String); function CurPosToSynPos(X, Y: Integer): TPoint; function GetTextSelected: Boolean; procedure SetGutterWidth(const Value: Integer); procedure SetShowInCodeComplition(const Value: TfrxCompletionListTypes); procedure SetCodeCompletionWidth(const Value: Integer); procedure SetCodeCompletionHeight(const Value: Integer); procedure SetCodeCompletionMinHeight(const Value: Integer); procedure SetCodeCompletionMinWidth(const Value: Integer); procedure PopCopy(Sender: TObject); procedure PopCut(Sender: TObject); procedure PopPaste(Sender: TObject); procedure PopDelete(Sender: TObject); procedure PopSelectAll(Sender: TObject); function GetAttributeStyles: TfrxAttributeStyles; procedure QuickComment; protected procedure DblClick; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key: Char); override; {$IFDEF FPC} procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override; {$ENDIF} procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure MouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure OnHScrollChange(Sender: TObject); override; procedure OnVScrollChange(Sender: TObject); override; procedure Resize; override; function GetCompletionString(Pos: TPoint): String; function GetFilter(aStr: String): String; procedure DoTimer(Sender: TObject); procedure DoPPIChanged(aNewPPI: Integer); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; procedure CopyToClipboard; procedure CutToClipboard; procedure CompletionClose; procedure PasteFromClipboard; procedure SelectAll; procedure SetPos(x, y: Integer); procedure SetPosByCoords(X, Y: Integer); procedure ShowMessage(const s: String); procedure Undo; procedure UpdateView; procedure ClearBreakPoints; function Find(const SearchText: String; CaseSensitive: Boolean; var SearchFrom: Integer): Boolean; function GetPlainPos: Integer; function GetPos: TPoint; function IsBookmark(Line: Integer): Integer; procedure AddBookmark(Line, Number: Integer); procedure DeleteBookmark(Number: Integer); procedure GotoBookmark(Number: Integer); procedure AddNewBreakPoint; procedure AddBreakPoint(Number: Integer; const Condition: String; const Special: String); procedure ToggleBreakPoint(Number: Integer; const Condition: String); procedure DeleteBreakPoint(Number: Integer); procedure DeleteF4BreakPoints; function IsBreakPoint(Number: Integer): Boolean; function IsActiveBreakPoint(Number: Integer): Boolean; function GetBreakPointCondition(Number: Integer): String; function GetBreakPointSpecialCondition(Number: Integer): String; procedure FillRtti; procedure SaveToIni(const IniPath: String; const Section: String; const FileName: String); procedure LoadFromIni(const IniPath: String; const Section: String; const FileName: String); // property DefaultAttributeStyles: TfrxAttributeStyles read FAttributeStyles; property EnableHint: Boolean read FEnableHint write SetEnableHint default True; property AttributeStyles: TfrxAttributeStyles read GetAttributeStyles; property CodeCompletionThread: TfrxCodeCompletionThread read FCodeCompletionThread; property CodeCompletionMinWidth: Integer read FCodeCompletionMinWidth write SetCodeCompletionMinWidth default 300; property CodeCompletionMinHeight: Integer read FCodeCompletionMinHeight write SetCodeCompletionMinHeight default 100; property CodeCompletionWidth: Integer read FCodeCompletionWidth write SetCodeCompletionWidth default 300; property CodeCompletionHeight: Integer read FCodeCompletionHeight write SetCodeCompletionHeight default 100; property ActiveLine: Integer read FActiveLine write SetActiveLine; property BlockColor: TColor read FBlockColor write FBlockColor; property BlockFontColor: TColor read FBlockFontColor write FBlockFontColor; property BreakPoints:{$IFDEF FPC}TBrkStringList{$ELSE}TStringList{$ENDIF} read FBreakPoints; property Color; property CommentAttr: TFont read FCommentAttr write SetCommentAttr; property CodeComplitionFilter: TfrxItemTypes read FCodeComplitionFilter write FCodeComplitionFilter; property ShowInCodeComplition: TfrxCompletionListTypes read FShowInCodeComplition write SetShowInCodeComplition; property SynDialectStyles: TfrxSynDialectStyles read FSynDialectStyles; property Font; {$IFNDEF FPC} property ImeMode; property ImeName; {$ENDIF} property SelStart: TPoint read FSelStart write FSelStart; property SelEnd: TPoint read FSelEnd write FSelEnd; property TabStops: Integer read FTabStops write FTabStops; property GutterWidth: Integer read FGutterWidth write SetGutterWidth; property KeywordAttr: TFont read FKeywordAttr write SetKeywordAttr; property Modified: Boolean read FModified write FModified; property MultiByteLang: Boolean read FMultiByteLang write FMultiByteLang; property NumberAttr: TFont read FNumberAttr write SetNumberAttr; property RunLine[Index: Integer]: Boolean read GetRunLine write SetRunLine; property SelText: String read GetSelText write SetSelText; property StringAttr: TFont read FStringAttr write SetStringAttr; property TextAttr: TFont read FTextAttr write SetTextAttr; property Lines: TStrings read GetText write SetText; property Syntax: String read FSyntax write SetSyntax; property Script: TfsScript read FScript write FScript; property ShowGutter: Boolean read FShowGutter write SetShowGutter; property ShowLineNumber: Boolean read FShowLineNumber write FShowLineNumber; property TextSelected: Boolean read GetTextSelected; property ScriptRTTIXML: TfsXMLDocument read FScriptRTTIXML; property OnChangePos: TNotifyEvent read FOnChangePos write FOnChangePos; property OnChangeText: TNotifyEvent read FOnChangeText write FOnChangeText; property OnCodeCompletion: TfrxCodeCompletionEvent read FOnCodeCompletion write FOnCodeCompletion; property OnDragDrop; property OnDragOver; property OnKeyDown; property PopupMenu; end; TDiffFunc = function(s1, s2: String): Integer; implementation uses Clipbrd, fs_itools, frxUtils, frxXML, IniFiles, Registry, frxDPIAwareInt, frxPlatformServices{$IFDEF FPC},RtlConsts{$ENDIF}; const SQLKeywords = 'active,after,all,alter,and,any,as,asc,ascending,at,auto,' + 'base_name,before,begin,between,by,cache,call,cast,check,column,commit,' + 'committed,computed,conditional,constraint,containing,count,create,' + 'current,cursor,database,debug,declare,default,delete,desc,descending,' + 'distinct,do,domain,drop,else,end,entry_point,escape,exception,execute,' + 'exists,exit,external,extract,filter,for,foreign,from,full,function,' + 'generator,grant,group,having,if,in,inactive,index,inner,insert,into,is,' + 'isolation,join,key,left,level,like,merge,names,no,not,null,of,on,only,' + 'or,order,outer,parameter,password,plan,position,primary,privileges,' + 'procedure,protected,read,retain,returns,revoke,right,rollback,schema,' + 'select,set,shadow,shared,snapshot,some,suspend,table,then,to,' + 'transaction,trigger,uncommitted,union,unique,update,user,using,values,' + 'view,wait,when,where,while,with,work'; SQLCommentLine1 = '--'; SQLCommentBlock1 = '/*,*/'; SQLStringQuotes = '"'; SQLHexSequence = '0x'; {$IFNDEF FPC} WordChars = ['a'..'z', 'A'..'Z', 'à'..'ÿ', 'À'..'ß', '0'..'9', '_']; {$ELSE} WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_']; {$ENDIF} {$IFDEF NONWINFPC} LineBreak: String = #$A; {$ELSE} LineBreak: String = #$D#$A; {$ENDIF} DefGutterWidth: Integer = 30; ReservedStylesCount = Byte(High(TCharAttr)); {$IFDEF Delphi12} function IsUnicodeChar(Chr: Char): Boolean; begin Result := ((Chr >= Char($007F)) and (Chr <= Char($FFFF))); end; {$ENDIF} procedure FilterCodeStringList(aFilterStr: String; aLBList: TStrings; aCodeList: TStrings; aDiffFunc: TDiffFunc); var i: Integer; Item: TfrxCompletionItem; function BuildName(Item: TfrxCompletionItem): String; begin Result := Item.FName; if (Item.FItemType in [itProcedure, itFunction]) and (Item.FParams <> '') then Result := Result + '(' + Item.FParams +')' else if Item.FItemType = itIndex then Result := Result + '[' + Item.FParams +']'; if (Item.FType <> '') and (Item.FItemType <> itType) then Result := Result + ':' + Item.FType; end; begin for i := 0 to aCodeList.Count - 1 do begin Item := TfrxCompletionItem(aCodeList.Objects[i]); if (aFilterStr = '') or (aDiffFunc(UpperCase(aFilterStr), UpperCase(aCodeList[i])) = 1) then aLBList.AddObject(BuildName(Item), Item); end; end; procedure FilterCodeListBox(aFilterStr: String; aListBox: TListBox; aCodeList: TStrings; aDiffFunc: TDiffFunc); begin aListBox.ItemIndex := -1; aListBox.Items.BeginUpdate; aListBox.Items.Clear; FilterCodeStringList(aFilterStr, aListBox.Items, aCodeList, aDiffFunc); if (aListBox.Count > 0) then aListBox.ItemIndex := 0; aListBox.Items.EndUpdate; end; function Diff(s1, s2: String): Integer; begin if (s1 = s2) then Result := 1 else Result := 0; end; function frxSynPos(s1, s2: String): Integer; begin Result := Pos(s1, s2); end; {$IFDEF FPC} { TBrkStringList } function TBrkStringList.AddObject(const S: string; AObject: TObject): Integer; begin If Not (SortStyle=sslAuto) then Result:= Count else If Find (S,Result) then Case DUplicates of DupIgnore : Exit; DupError : Error(SDuplicateString,0) end; InsertItem (Result,S, AObject); end; {$ENDIF} { TfrxSyntaxMemo } constructor TfrxSyntaxMemo.Create(AOwner: TComponent); var i: Integer; begin inherited; {$IFDEF JPN} FMultiByteLang := True; {$ENDIF} FSynDialectStyles := TfrxSynDialectStyles.Create; // FAttributeStyles := TfrxAttributeStyles.Create; {$IFNDEF FPC} FTmpCanvas := TBitmap.Create; {$ENDIF} {$IFDEF NONWINFPC} FCaretCreated := False; {$ENDIF} DoubleBuffered := True; TabStop := True; Cursor := crIBeam; Color := clWindow; FBreakPoints := {$IFDEF FPC}TBrkStringList.Create{$ELSE}TStringList.Create{$ENDIF}; FBlockColor := clHighlight; FBlockFontColor := clHighlightText; FCommentAttr := TFont.Create; FCommentAttr.Color := clNavy; FCommentAttr.Style := [fsItalic]; FKeywordAttr := TFont.Create; FKeywordAttr.Color := clWindowText; FKeywordAttr.Style := [fsBold]; FNumberAttr := TFont.Create; FNumberAttr.Color := clGreen; FNumberAttr.Style := []; FStringAttr := TFont.Create; FStringAttr.Color := clNavy; FStringAttr.Style := []; FTextAttr := TFont.Create; FTextAttr.Color := clWindowText; FTextAttr.Style := []; Font.Size := 10; Font.Name := 'Courier New'; FText := TStringList.Create; FParser := TfsParser.Create; FParser.SkipSpace := False; FParser.UseY := False; //FSynStrings := TStringList.Create; FSynAttributes := TfrxSynAttributes.Create(FParser, FSynDialectStyles); FUndo := TStringList.Create; FText.Add(''); FText.OnChange := LinesChange; FMaxLength := 1024; FMoved := True; SetPos(1, 1); FTabStops := 2; ShowGutter := True; OnMouseWheelUp := MouseWheelUp; OnMouseWheelDown := MouseWheelDown; FActiveLine := -1; for i := 0 to 9 do FBookmarks[i] := -1; FScriptRTTIXML := TfsXMLDocument.Create; FRttiCompletionList := TfrxCompletionList.Create; FScriptCompletionList := TfrxCompletionList.Create; FAddonCompletionList := TfrxCompletionList.Create; FClassCompletionList := TfrxCompletionList.Create; FTimer := TTimer.Create(nil); FTimer.Interval := 1000; FTimer.OnTimer := DoTimer; FTimer.Enabled := False; FCodeCompList := TStringList.Create; FCodeCompletionThread := TfrxCodeCompletionThread.Create(True); FCodeCompletionThread.FText := FText; FCodeCompletionThread.FCompletionList := FScriptCompletionList; FShowLineNumber := True; FCodeComplitionFilter := [itVar, itProcedure, itFunction, itProperty, itIndex, itConstant, itConstructor, itType, itEvent]; FShowInCodeComplition := [cltRtti, cltScript, cltAddon]; FCodeCompletionHeight := 100; FCodeCompletionWidth := 300; FCodeCompletionMinHeight := 100; FCodeCompletionMinWidth := 300; PopupMenu := TPopupMenu.Create(Self); PopupMenu.Items.Clear; PopupMenu.Items.Add(NewItem(frxGet(2407), 0, False, True, PopCut , 0, 'MenuItem1')); PopupMenu.Items.Add(NewItem(frxGet(2408), 0, False, True, PopCopy , 0, 'MenuItem2')); PopupMenu.Items.Add(NewItem(frxGet(2409), 0, False, True, PopPaste , 0, 'MenuItem3')); PopupMenu.Items.Add(NewItem(frxGet(2412), 0, False, True, PopDelete , 0, 'MenuItem4')); PopupMenu.Items.Add(NewItem(frxGet(2414), 0, False, True, PopSelectAll, 0, 'MenuItem5')); PopupMenu.Images := frxResources.MainButtonImages; PopupMenu.Items[0].ImageIndex := 5; PopupMenu.Items[1].ImageIndex := 6; PopupMenu.Items[2].ImageIndex := 7; PopupMenu.Items[3].ImageIndex := 51; EnableHint := True; end; destructor TfrxSyntaxMemo.Destroy; begin {$IFNDEF FPC} FTmpCanvas.Free; {$ENDIF} ClearBreakPoints; FreeAndNil(FTimer); {$IFDEF LCLGTK2} if Assigned(FCodeCompletionThread) then begin FCodeCompletionThread.Terminate; FCodeCompletionThread.Resume; end; {$ELSE} if Assigned(FCodeCompletionThread) then FCodeCompletionThread.Terminate; {$ENDIF} FreeAndNil(FCodeCompletionThread); FreeAndNil(FBreakPoints); FreeAndNil(FCommentAttr); FreeAndNil(FKeywordAttr); FreeAndNil(FNumberAttr); FreeAndNil(FStringAttr); FreeAndNil(FTextAttr); FreeAndNil(FText); FreeAndNil(FUndo); FreeAndNil(FSynAttributes); FreeAndNil(FSynDialectStyles); FreeAndNil(FParser); FreeAndNil(FScriptRTTIXML); FreeAndNil(FRttiCompletionList); FreeAndNil(FScriptCompletionList); FreeAndNil(FAddonCompletionList); FreeAndNil(FClassCompletionList); FreeAndNil(FCodeCompList); inherited; end; procedure TfrxSyntaxMemo.WMFRXFillCodeCompletion(var Message: TMessage); begin if Assigned(FCodeCompletionThread) then FCodeCompletionThread.FillCodeCompletion; end; procedure TfrxSyntaxMemo.SetEnableHint(vEnableHint: boolean); begin FEnableHint := vEnableHint; if (vEnableHint) then FfrxHintShowEvent := RealHintShow else FfrxHintShowEvent := FakeHintShow; end; procedure TfrxSyntaxMemo.FakeHintShow(var Msg: TCMHintShow); begin //do nothing end; procedure TfrxSyntaxMemo.RealHintShow(var Msg: TCMHintShow); var PropName, PropText: String; BufP: TPoint; Header, Prefix: String; begin BufP := Msg.HintInfo.CursorPos; BufP := CurPosToSynPos(BufP.X, BufP.Y); GetCurWord(BufP, Prefix, Header, PropText); PropName := 'prop' + PropText; PropText := frxResources.Get(PropName); { TODO: Make parameters description } if (PropName = PropText) then PropText := frxResources.Get('dtNoData'); if (Header <> '') then begin Msg.HintInfo.HintStr := PropText; Msg.HintInfo.HintWindowClass := TBaseHintWindow; Msg.HintInfo.HintData := TBaseHintData.Create(Prefix + ' ', Header + ';', True); Msg.HintInfo.HideTimeout := MaxInt; end else Msg.HintInfo.HintStr := ''; end; procedure TfrxSyntaxMemo.WMFRXHintShow(var Msg: TCMHintShow); begin inherited; FfrxHintShowEvent(Msg); end; function TfrxSyntaxMemo.OffsPoint(Point: TPoint): TPoint; var i: Integer; s: String; function IsWord(c: Char): Boolean; begin {$IFDEF Delphi12} Result := CharInSet(c, ['a'..'z', 'A'..'Z', '0'..'9']); {$ELSE} Result := c in ['a'..'z', 'A'..'Z', '0'..'9']; {$ENDIF} end; begin s := LineAt(Point.Y - 1, False); if Point.X > Length(s) then Point.X := Length(s) + 1 else if IsWord(s[Point.X]) then for i := Point.X to Length(s) do begin if IsWord(s[i]) then Point.X := Point.X + 1 else break; end; Result := Point; end; procedure TfrxSyntaxMemo.GetCurWord(Point: TPoint; var Prefix: String; var Header: String; var TextHint: String); var s: String; FCodeHintList: TStringList; FCompletionHintLB: TStringList; FHintFilter: String; begin Point := OffsPoint(Point); FCodeHintList := TStringList.Create; FCompletionHintLB := TStringList.Create; FScriptCompletionList.Locked := True; try s := Trim(GetCompletionString(Point)); FHintFilter := GetFilter(s); TextHint := FHintFilter; if FHintFilter = s then s := ''; FAddonCompletionList.DestroyItems; if Assigned(FOnCodeCompletion) and (cltAddon in FShowInCodeComplition) then FOnCodeCompletion(s, FAddonCompletionList); BuildCClist(s, FCodeHintList, True); FilterCodeStringList(FHintFilter, FCompletionHintLB, FCodeHintList, @Diff); if FCompletionHintLB.Count > 0 then begin Header := FCompletionHintLB[0]; ItemToPrefix(TfrxCompletionItem(FCompletionHintLB.Objects[0]), Prefix); end; finally FCodeHintList.Free; FCompletionHintLB.Free; FScriptCompletionList.Locked := False; end; end; function TfrxSyntaxMemo.CurPosToSynPos(X, Y: Integer): TPoint; begin Result.X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; Result.Y := Y div FCharHeight + 1 + FOffset.Y; end; procedure TfrxSyntaxMemo.WMFRXSyncScript(var Message: TMessage); begin if Assigned(FCodeCompletionThread) then FCodeCompletionThread.SyncScript; end; procedure TfrxSyntaxMemo.WMFRXUpdateCode(var Message: TMessage); begin if Assigned(FCodeCompletionThread) then FCodeCompletionThread.UpdateCode; end; {$IFNDEF FPC} { updating IME string and carret pos } procedure TfrxSyntaxMemo.WMIMECOMPOSITION(var Message: TMessage); procedure UpdateComposition(aFlag: DWORD); var h: HIMC; nLen, nPos: Integer; StrBuf: String; begin h := Imm32GetContext(Handle); if h <> 0 then begin if aFlag = GCS_COMPSTR then nPos := Imm32GetCompositionString(h, GCS_CURSORPOS, nil, 0) else nPos := 0; nLen := Imm32GetCompositionString(h, aFlag, nil, 0); if nLen <> 0 then begin SetLength(StrBuf, nLen div 2); Imm32GetCompositionString(h, aFlag, @StrBuf[1], nLen); if (nLen div 2) > FCompSelEnd.X - FCompSelStart.X then FCompSelEnd.X := FCompSelStart.X + (nLen div 2) - 1; FSelStart.Y := FCompSelStart.Y; FSelStart.X := FCompSelStart.X; FSelEnd.Y := FCompSelEnd.Y; FSelEnd.X := FCompSelEnd.X; SelText := StrBuf; FPos.X := FCompSelStart.X + nPos + (nLen div 2); SetPos(FPos.X, FPos.Y); FCompSelEnd.X := FCompSelStart.X + (nLen div 2); Invalidate; end; Imm32ReleaseContext(Handle, h); end; end; begin if (Message.LParam = $1E00) and (Message.WParam <> 12288) and (Message.WParam <> 32) then ResetImeComposition(CPS_CANCEL) else if (Message.LParam and GCS_RESULTSTR) = GCS_RESULTSTR then begin UpdateComposition(GCS_RESULTSTR); FCompSelStart := FCompSelEnd; end else begin UpdateComposition(GCS_COMPSTR); Inherited; end; end; procedure TfrxSyntaxMemo.WMIMEEndComp(var Message: TMessage); begin FInImeComposition := False; end; procedure TfrxSyntaxMemo.WMIMEStartComp(var Message: TMessage); begin FCompSelStart.Y := FPos.Y; FCompSelStart.X := FPos.X; FCompSelEnd.Y := FPos.Y; FCompSelEnd.X := FPos.X; FInImeComposition := True; end; {$ENDIF} procedure TfrxSyntaxMemo.WMKillFocus(var Msg: TWMKillFocus); begin inherited; if Assigned(FCompletionForm) then Exit; {$IFDEF NONWINFPC} if not FCaretCreated then exit else FCaretCreated := False; {$ENDIF} HideCaret(Handle); DestroyCaret{$IFDEF FPC}(Handle){$ENDIF}; end; procedure TfrxSyntaxMemo.WMSetFocus(var Msg: TWMSetFocus); begin inherited; {$IFDEF NONWINFPC} if not HandleAllocated then exit else FCaretCreated := True; {$ENDIF} CreateCaret(Handle, 0, 2, FCharHeight); ShowCaretPos; end; procedure TfrxSyntaxMemo.ShowCaretPos; {$IFNDEF FPC} var cWidth: Integer; LineLen: Integer; {$ENDIF} begin if FPos.X > FOffset.X then begin {$IFNDEF FPC} if FMultiByteLang then begin cWidth := GetCharWidth(Copy(LineAt(FPos.Y - 1), FOffset.X, FPos.X - 1 - FOffset.X)); LineLen := LineLength(FPos.Y - 1); if LineLen < FPos.X then cWidth := cWidth + FCharWidth * (FPos.X - 1 - LineLen); end else cWidth := FCharWidth * (FPos.X - 1 - FOffset.X); SetCaretPos(cWidth + FGutterWidth, FCharHeight * (FPos.Y - 1 - FOffset.Y)); {$ELSE} SetCaretPos(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, FCharHeight * (FPos.Y - 1 - FOffset.Y)); {$ENDIF} {$IFDEF NONWINFPC} if FCaretCreated then Update; {$ELSE} ShowCaret(Handle); {$ENDIF} end else SetCaretPos(-100, -100); if Assigned(FOnChangePos) then FOnChangePos(Self); end; procedure TfrxSyntaxMemo.CMFontChanged(var Message: TMessage); var b: TBitmap; begin FCommentAttr.PixelsPerInch := Font.PixelsPerInch; FCommentAttr.Size := Font.Size; FCommentAttr.Name := Font.Name; FKeywordAttr.PixelsPerInch := Font.PixelsPerInch; FKeywordAttr.Size := Font.Size; FKeywordAttr.Name := Font.Name; FNumberAttr.PixelsPerInch := Font.PixelsPerInch; FNumberAttr.Size := Font.Size; FNumberAttr.Name := Font.Name; FStringAttr.PixelsPerInch := Font.PixelsPerInch; FStringAttr.Size := Font.Size; FStringAttr.Name := Font.Name; FTextAttr.PixelsPerInch := Font.PixelsPerInch; FTextAttr.Size := Font.Size; FTextAttr.Name := Font.Name; b := TBitmap.Create; with b.Canvas do begin Font.PixelsPerInch := Self.Font.PixelsPerInch; Font.Assign(Self.Font); Font.Style := [fsBold]; FCharHeight := TextHeight('Wg') + 1; FCharWidth := TextWidth('W'); FIsMonoType := Pos('COURIER NEW', AnsiUppercase(Self.Font.Name)) <> 0; end; b.Free; end; procedure TfrxSyntaxMemo.Resize; begin inherited; if FCharWidth = 0 then Exit; FWindowSize := Point((ClientWidth - FGutterWidth) div FCharWidth, ClientHeight div FCharHeight); {$IFDEF FPC} if (ClientHeight > 0) and (ClientWidth > 0) then begin HorzPage := FWindowSize.X; VertPage := FWindowSize.Y; UpdateScrollBar; end; {$ELSE} HorzPage := FWindowSize.X; VertPage := FWindowSize.Y; UpdateScrollBar; {$ENDIF} end; procedure TfrxSyntaxMemo.UpdateScrollBar; begin VertRange := FText.Count; HorzRange := FMaxLength; LargeChange := FWindowSize.Y; VertPosition := FOffset.Y; HorzPosition := FOffset.X; end; function TfrxSyntaxMemo.GetText: TStrings; //var // i: Integer; begin // FAllowLinesChange := False; // for i := 0 to FText.Count - 1 do // FText[i] := LineAt(i); Result := FText; FAllowLinesChange := True; end; function TfrxSyntaxMemo.GetPlainPos: Integer; begin Result := GetPlainTextPos(FPos); end; function TfrxSyntaxMemo.GetPos: TPoint; begin Result := FPos; end; procedure TfrxSyntaxMemo.SetText(Value: TStrings); begin FAllowLinesChange := True; FText.Assign(Value); DoChange; end; procedure TfrxSyntaxMemo.SetSyntax(const Value: String); var sl: TStringList; procedure GetGrammar; var Grammar: TfrxXMLDocument; ss: TStringStream; ParserRoot, xi: TfrxXMLItem; i: Integer; Name, PropText: String; begin Grammar := TfrxXMLDocument.Create; ss := TStringStream.Create(fsGetLanguage(Value){$IFDEF Delphi12}, TEncoding.UTF8{$ENDIF}); Grammar.LoadFromStream(ss); ss.Free; ParserRoot := Grammar.Root.FindItem('parser'); xi := ParserRoot.FindItem('keywords'); for i := 0 to xi.Count - 1 do FParser.Keywords.Add(xi[i].Name); for i := 0 to ParserRoot.Count - 1 do begin Name := LowerCase(ParserRoot[i].Name); PropText := ParserRoot[i].Prop['text']; if Name = 'identchars' then FParser.ConstructCharset(PropText) else if Name = 'commentline1' then FParser.CommentLine1 := PropText else if Name = 'commentline2' then FParser.CommentLine2 := PropText else if Name = 'commentblock1' then FParser.CommentBlock1 := PropText else if Name = 'commentblock2' then FParser.CommentBlock2 := PropText else if Name = 'stringquotes' then FParser.StringQuotes := PropText else if Name = 'hexsequence' then FParser.HexSequence := PropText end; Grammar.Free; end; begin FSyntax := Value; FParser.Keywords.Clear; sl := TStringList.Create; if AnsiCompareText(Value, 'SQL') = 0 then FSynAttributes.UpdateSyntaxDialect else begin fsGetLanguageList(sl); if sl.IndexOf(Value) <> -1 then GetGrammar; end; ClearSyntax(1); sl.Free; end; procedure TfrxSyntaxMemo.SetCodeCompletionHeight(const Value: Integer); begin FCodeCompletionHeight := Value; CompletionClose; end; procedure TfrxSyntaxMemo.SetCodeCompletionMinHeight(const Value: Integer); begin FCodeCompletionMinHeight := Value; CompletionClose; end; procedure TfrxSyntaxMemo.SetCodeCompletionMinWidth(const Value: Integer); begin FCodeCompletionMinWidth := Value; CompletionClose; end; procedure TfrxSyntaxMemo.PopCopy(Sender: TObject); begin Self.CopyToClipboard; end; procedure TfrxSyntaxMemo.PopCut(Sender: TObject); begin Self.CutToClipboard; end; procedure TfrxSyntaxMemo.PopPaste(Sender: TObject); begin Self.PasteFromClipboard; end; procedure TfrxSyntaxMemo.PopDelete(Sender: TObject); var buf: Word; begin buf := vk_Delete; Self.KeyDown(buf, []); end; procedure TfrxSyntaxMemo.PopSelectAll(Sender: TObject); begin Self.SelectAll; end; procedure TfrxSyntaxMemo.SetCodeCompletionWidth(const Value: Integer); begin FCodeCompletionWidth := Value; CompletionClose; end; procedure TfrxSyntaxMemo.SetCommentAttr(Value: TFont); begin FCommentAttr.Assign(Value); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetGutterWidth(const Value: Integer); begin if FGutterWidth <> Value then begin FGutterWidth := Value; Invalidate; end; end; procedure TfrxSyntaxMemo.SetKeywordAttr(Value: TFont); begin FKeywordAttr.Assign(Value); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetNumberAttr(const Value: TFont); begin FNumberAttr.Assign(Value); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetStringAttr(Value: TFont); begin FStringAttr.Assign(Value); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetTextAttr(Value: TFont); begin FTextAttr.Assign(Value); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetActiveLine(Line: Integer); begin FActiveLine := Line; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.DoChange; begin FModified := True; FTimer.Enabled := (FCompletionForm = nil) and (cltScript in FShowInCodeComplition) and Assigned(FScript); if Assigned(FOnChangeText) then FOnChangeText(Self); end; procedure TfrxSyntaxMemo.LinesChange(Sender: TObject); begin if FAllowLinesChange then begin FAllowLinesChange := False; if FText.Count = 0 then FText.Add(''); ClearSyntax(1); FMoved := True; FUndo.Clear; FPos := Point(1, 1); FOffset := Point(0, 0); ClearSel; ShowCaretPos; UpdateScrollBar; end; end; procedure TfrxSyntaxMemo.ShowMessage(const s: String); begin FMessage := s; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.CopyToClipboard; begin if FSelStart.X <> 0 then Clipboard.AsText := SelText; end; procedure TfrxSyntaxMemo.CutToClipboard; begin if FSelStart.X <> 0 then begin Clipboard.AsText := SelText; SelText := ''; end; CorrectBookmark(FSelStart.Y, FSelStart.Y - FSelEnd.Y); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.PasteFromClipboard; begin SelText := Clipboard.AsText; end; procedure TfrxSyntaxMemo.SelectAll; begin SetPos(0, 0); FSelStart := FPos; SetPos(LineLength(FText.Count - 1) + 1, FText.Count); FSelEnd := FPos; {$IFDEF FPC} frxUpdateControl(Self, True); {$ELSE} Repaint; {$ENDIF} end; function TfrxSyntaxMemo.LineAt(Index: Integer; UseTrim: Boolean = True): String; begin if Index < FText.Count then begin if UseTrim then Result := TrimRight(FText[Index]) else Result := FText[Index]; end else Result := ''; end; function TfrxSyntaxMemo.LineLength(Index: Integer): Integer; begin Result := frxLength(LineAt(Index)); end; function TfrxSyntaxMemo.Pad(n: Integer): String; begin Result := ''; SetLength(Result, n); {$IFDEF Delphi12} Result := StringOfChar(Char(' '), n); {$ELSE} FillChar(Result[1], n, ' '); {$ENDIF} end; procedure TfrxSyntaxMemo.AddUndo; begin if not FMoved then exit; FUndo.Add(Format('%5d%5d', [FPos.X, FPos.Y]) + FText.Text); if FUndo.Count > 32 then FUndo.Delete(0); FMoved := False; end; procedure GenerateClassList(Prog: TfsScript; cl: TClass; aList: TfrxCompletionList); var i, j, k: Integer; v: TfsCustomVariable; c: TfsClassVariable; clItem: TfsCustomHelper; Params: String; Item: TfrxCompletionItem; begin aList.DestroyItems; for i := 0 to Prog.Count - 1 do begin v := Prog.Items[i]; if v is TfsClassVariable then begin c := TfsClassVariable(v); if cl.InheritsFrom(c.ClassRef) then begin for j := 0 to c.MembersCount - 1 do begin clItem := c.Members[j]; if clItem is TfsPropertyHelper then begin Item := aList.AddVariable(clItem.Name, clItem.GetFullTypeName); Item.FItemType := itProperty; end else if clItem is TfsMethodHelper then begin Params := ''; for k := 0 to clItem.Count - 1 do begin if k > 0 then Params := Params + ';'; Params := Params + clItem.Params[k].Name + ': ' + clItem.Params[k].TypeName; end; Item := aList.AddFunction(clItem.Name, clItem.GetFullTypeName, Params); if TfsMethodHelper(clItem).IndexMethod then Item.FItemType := itIndex; end else begin Item := aList.AddVariable(clItem.Name, clItem.GetFullTypeName); Item.FItemType := itEvent; end; end; end; end; end; end; procedure TfrxSyntaxMemo.BuildCClist(const sName: String; aCodeCompList: TStringList; AllFunc: Boolean = False); var members: TStringList; i: Integer; Item: TfrxCompletionItem; clName: String; clVar: TfsClassVariable; clMethod: TfsCustomHelper; procedure FillMembers(const Text: String; Comma: Char = ';'); var i, ipos: Integer; Len: Integer; begin members.Clear; ipos := -1; Len := Length(Text); for i := Len downto 1 do begin if (Text[i] = Comma) then begin if ipos <> -1 then members.Insert(0, Copy(Text, i + 1, (iPos - 1 - i))); ipos := i; end else if (i = 1) then begin members.Insert(0, Copy(Text, i, (iPos - i))); end; end; end; begin members := TStringList.Create; members.Duplicates := dupAccept; FillMembers(sName, '.'); FClassCompletionList.DestroyItems; if members.Count = 0 then begin for i := 0 to FAddonCompletionList.Count - 1 do aCodeCompList.AddObject(FAddonCompletionList[i].FName, FAddonCompletionList[i]); for i := 0 to FScriptCompletionList.Count - 1 do if AllFunc or (FPos.Y >= FScriptCompletionList[i].FStartVisible) and ((FPos.Y <= FScriptCompletionList[i].FEndVisible) or (FScriptCompletionList[i].FEndVisible = -1)) then aCodeCompList.AddObject(FScriptCompletionList[i].FName, FScriptCompletionList[i]); for i := 0 to FRttiCompletionList.Count - 1 do aCodeCompList.AddObject(FRttiCompletionList[i].FName, FRttiCompletionList[i]); end; if Members.Count > 0 then begin Item := FAddonCompletionList.Find(Members[0]); if Item = nil then Item := FScriptCompletionList.Find(Members[0]); if Item = nil then Item := FRttiCompletionList.Find(Members[0]); if (Item <> nil) and (Item.FStartVisible < FPos.Y) and ((Item.FEndVisible > FPos.Y) or (Item.FEndVisible < 0)) then begin clName := Item.FType; i := 1; while (clName <> '') and (i < Members.Count) do begin clVar := FScript.FindClass(clName); clName := ''; if clVar <> nil then begin clMethod := clVar.Find(Members[i]); if clMethod <> nil then clName := clMethod.TypeName; Inc(i); end; end; if clName <> '' then begin clVar := FScript.FindClass(clName); if clVar <> nil then GenerateClassList(FScript, FScript.FindClass(clName).ClassRef, FClassCompletionList); end; end; end; for i := 0 to FClassCompletionList.Count - 1 do aCodeCompList.AddObject(FClassCompletionList[i].FName, FClassCompletionList[i]); FreeAndNil(Members); end; procedure TfrxSyntaxMemo.Undo; var s: String; begin FMoved := True; if FUndo.Count = 0 then exit; s := FUndo[FUndo.Count - 1]; FPos.X := StrToInt(Copy(s, 1, 5)); FPos.Y := StrToInt(Copy(s, 6, 5)); FAllowLinesChange := False; FText.Text := Copy(s, 11, Length(s) - 10); FAllowLinesChange := True; FUndo.Delete(FUndo.Count - 1); SetPos(FPos.X, FPos.Y); ClearSyntax(1); DoChange; end; function TfrxSyntaxMemo.GetPlainTextPos(Pos: TPoint): Integer; var i: Integer; begin Result := 0; for i := 0 to Pos.Y - 2 do Result := Result + frxLength(FText[i]) + {$IFDEF FPC}Length(LineBreak){$ELSE}2{$ENDIF}; Result := Result + Pos.X; end; function TfrxSyntaxMemo.GetPosPlainText(Pos: Integer): TPoint; var i: Integer; s: String; begin Result := Point(0, 1); s := FText.Text; i := 1; while i <= Pos do if frxGetSymbol(s, i) = LineBreak[1] then begin Inc(i, length(LineBreak)); if i <= Pos then begin Inc(Result.Y); Result.X := 0; end else Inc(Result.X); end else begin Inc(i); Inc(Result.X); end; end; function TfrxSyntaxMemo.GetLineBegin(Index: Integer): Integer; var s: String; begin s := FText[Index]; Result := 1; if Trim(s) <> '' then for Result := 1 to Length(s) do if s[Result] <> ' ' then break; end; procedure TfrxSyntaxMemo.TabIndent; begin SelText := Pad(FTabStops - ((FPos.X - 1) mod FTabStops)); end; procedure TfrxSyntaxMemo.EnterIndent; var res: Integer; begin if Trim(FText[FPos.Y - 1]) = '' then res := FPos.X else res := GetLineBegin(FPos.Y - 1); if FPos.X = 1 then CorrectBookmark(FPos.Y - 1, 1) else CorrectBookmark(FPos.Y, 1); FPos := Point(1, FPos.Y + 1); SelText := Pad(res - 1); end; procedure TfrxSyntaxMemo.UnIndent; var i, res: Integer; begin i := FPos.Y - 2; res := FPos.X - 1; CorrectBookmark(FPos.Y, -1); while i >= 0 do begin res := GetLineBegin(i); if (res < FPos.X) and (Trim(FText[i]) <> '') then break else Dec(i); end; FSelStart := FPos; FSelEnd := FPos; Dec(FSelEnd.X, FPos.X - res); SelText := ''; end; procedure TfrxSyntaxMemo.ShiftSelected(ShiftRight: Boolean); var i, ib, ie: Integer; s: String; Shift: Integer; begin AddUndo; if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then begin ib := FSelStart.Y - 1; ie := FSelEnd.Y - 1; end else begin ib := FSelEnd.Y - 1; ie := FSelStart.Y - 1; end; if FSelEnd.X = 1 then Dec(ie); Shift := 2; if not ShiftRight then for i := ib to ie do begin s := FText[i]; if (Trim(s) <> '') and (GetLineBegin(i) - 1 < Shift) then Shift := GetLineBegin(i) - 1; end; for i := ib to ie do begin s := FText[i]; if ShiftRight then s := Pad(Shift) + s else if Trim(s) <> '' then frxDelete(s, 1, Shift); FText[i] := s; end; ClearSyntax(FSelStart.Y); DoChange; end; function TfrxSyntaxMemo.GetSelText: String; var p1, p2: TPoint; i: Integer; begin if FSelStart.X = 0 then begin Result := ''; Exit; end; if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then begin p1 := FSelStart; p2 := FSelEnd; Dec(p2.X); end else begin p1 := FSelEnd; p2 := FSelStart; Dec(p2.X); end; if LineLength(p1.Y - 1) < p1.X then begin Inc(p1.Y); p1.X := 1; end; if LineLength(p2.Y - 1) < p2.X then p2.X := LineLength(p2.Y - 1); i := GetPlainTextPos(p1); Result := frxCopy(FText.Text, i, GetPlainTextPos(p2) - i + 1); end; procedure TfrxSyntaxMemo.SetSelText(const Value: String); var p1, p2, p3: TPoint; i, k: Integer; s: String; begin AddUndo; if FSelStart.X = 0 then begin p1 := FPos; p2 := p1; Dec(p2.X); end else if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then begin p1 := FSelStart; p2 := FSelEnd; Dec(p2.X); end else begin p1 := FSelEnd; p2 := FSelStart; Dec(p2.X); end; FAllowLinesChange := False; if LineLength(p1.Y - 1) < p1.X then FText[p1.Y - 1] := FText[p1.Y - 1] + Pad(p1.X - LineLength(p1.Y - 1) + 1); if LineLength(p2.Y - 1) < p2.X then p2.X := LineLength(p2.Y - 1); i := GetPlainTextPos(p1); s := FText.Text; k := GetPlainTextPos(p2) - i + 1; if K > 0 then frxDelete(s, i, k); frxInsert(Value, s, i); FText.Text := s; p3 := GetPosPlainText(i + frxLength(Value)); FAllowLinesChange := True; CorrectBookmark(FPos.Y, p3.y - FPos.Y); SetPos(p3.X, p3.Y); FSelStart.X := 0; DoChange; i := p3.Y; if p2.Y < i then i := p2.Y; if p1.Y < i then i := p1.Y; ClearSyntax(i); end; procedure TfrxSyntaxMemo.ClearSel; begin if FSelStart.X <> 0 then begin FSelStart := Point(0, 0); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; end; procedure TfrxSyntaxMemo.AddSel; begin if FSelStart.X = 0 then FSelStart := FTempPos; FSelEnd := FPos; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetPos(x, y: Integer); begin if FMessage <> '' then begin FMessage := ''; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; if x > FMaxLength then x := FMaxLength; if x < 1 then x := 1; if y > FText.Count then y := FText.Count; if y < 1 then y := 1; FPos := Point(x, y); if (FWindowSize.X = 0) or (FWindowSize.Y = 0) then exit; if FOffset.Y >= FText.Count then FOffset.Y := FText.Count - 1; if FPos.X > FOffset.X + FWindowSize.X then begin Inc(FOffset.X, FPos.X - (FOffset.X + FWindowSize.X)); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end else if FPos.X <= FOffset.X then begin Dec(FOffset.X, FOffset.X - FPos.X + 1); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end else if FPos.Y > FOffset.Y + FWindowSize.Y then begin Inc(FOffset.Y, FPos.Y - (FOffset.Y + FWindowSize.Y)); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end else if FPos.Y <= FOffset.Y then begin Dec(FOffset.Y, FOffset.Y - FPos.Y + 1); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; ShowCaretPos; UpdateScrollBar; end; procedure TfrxSyntaxMemo.SetPosByCoords(X, Y: Integer); begin {$IFNDEF FPC} if FMultiByteLang then X := GetCharXPos(X - FGutterWidth)+ 1 + FOffset.X else {$ENDIF} X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; Y := Y div FCharHeight + 1 + FOffset.Y; FTempPos := FPos; SetPos(X, Y); end; procedure TfrxSyntaxMemo.OnHScrollChange(Sender: TObject); begin FOffset.X := HorzPosition; if FOffset.X > 1024 then FOffset.X := 1024; ShowCaretPos; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.OnVScrollChange(Sender: TObject); begin FOffset.Y := VertPosition; if FOffset.Y > FText.Count then FOffset.Y := FText.Count; ShowCaretPos; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.DblClick; var s: String; begin FDoubleClicked := True; DoCtrlL; FSelStart := FPos; s := LineAt(FPos.Y - 1); if s <> '' then {$IFDEF Delphi12} while CharInSet(s[FPos.X], WordChars) or IsUnicodeChar(s[FPos.X]) do {$ELSE} {$IFDEF FPC} while (Length(frxGetSymbol(s, FPos.X)) >= 1) and ((frxGetSymbol(s, FPos.X)[1] in WordChars) or (frxGetSymbol(s, FPos.X) >= 'À') and (frxGetSymbol(s, FPos.X) <= 'ÿ')) do {$ELSE} while s[FPos.X] in WordChars do {$ENDIF} {$ENDIF} Inc(FPos.X); FSelEnd := FPos; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var selected: Boolean; begin if FDoubleClicked then begin FDoubleClicked := False; Exit; end else if (Button = mbRight) then begin selected := (FSelStart.X <> 0) and ((FSelStart.X <> FSelEnd.X) or (FSelStart.Y <> FSelEnd.Y)); PopupMenu.Items[0].Enabled := selected; PopupMenu.Items[1].Enabled := selected; PopupMenu.Items[2].Enabled := Clipboard.HasFormat(CF_TEXT); PopupMenu.Items[3].Enabled := selected; Exit; end; FMoved := True; if not Focused then SetFocus; FDown := True; if X < FGutterWidth then FToggleBreakPointDown := True; {$IFNDEF FPC} if FMultiByteLang then X := GetCharXPos(X - FGutterWidth)+ 1 + FOffset.X else {$ENDIF} X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; Y := Y div FCharHeight + 1 + FOffset.Y; FTempPos := FPos; SetPos(X, Y); if ssShift in Shift then AddSel else ClearSel; end; procedure TfrxSyntaxMemo.MouseMove(Shift: TShiftState; X, Y: Integer); var CurHintPos: TPoint; begin if FDown then begin FTempPos := FPos; FPos := CurPosToSynPos(X, Y); if (FPos.X <> FTempPos.X) or (FPos.Y <> FTempPos.Y) then begin SetPos(FPos.X, FPos.Y); AddSel; end; end; if X < FGutterWidth then Cursor := crArrow else Cursor := crIBeam; CurHintPos := CurPosToSynPos(X, Y); if (CurHintPos.X < 1) or (CurHintPos.Y < 1) then begin Application.CancelHint; FLastHintPos := Point(-1, -1); Exit; end; CurHintPos := OffsPoint(CurHintPos); if ((CurHintPos.X <> FLastHintPos.X) or (CurHintPos.Y <> FLastHintPos.Y)) then begin Application.CancelHint; FLastHintPos := CurHintPos; end; end; procedure TfrxSyntaxMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FDown := False; if (X < FGutterWidth) and (FToggleBreakPointDown) then ToggleBreakPoint(FPos.Y, ''); FToggleBreakPointDown := False; end; procedure TfrxSyntaxMemo.KeyDown(var Key: Word; Shift: TShiftState); var MyKey: Boolean; TempPos: Tpoint; begin inherited; FAllowLinesChange := False; FTempPos := FPos; MyKey := True; case Key of vk_Left: if ssCtrl in Shift then DoCtrlL else DoLeft; vk_Right: if ssCtrl in Shift then DoCtrlR else DoRight; vk_Up: DoUp; vk_Down: DoDown; vk_Home: DoHome(ssCtrl in Shift); vk_End: DoEnd(ssCtrl in Shift); vk_Prior: DoPgUp; vk_Next: DoPgDn; vk_Return: if Shift = [] then DoReturn; vk_Delete: begin if ssCtrl in Shift then // Ctrl+Del delete word before cursor begin TempPos := FPos; Inc(FPos.X); DblClick; FDoubleClicked := False; if FSelEnd.X <= TempPos.X then begin FSelStart := TempPos; FSelEnd := TempPos; dec(FSelStart.X); end; end; if ssShift in Shift then CutToClipboard else DoDel; end; vk_Back: begin if ssCtrl in Shift then // Ctrl+BackSpace delete word after cursor begin DblClick; FDoubleClicked := False; end; DoBackspace; end; vk_Insert: if ssCtrl in Shift then CopyToClipboard else if ssShift in Shift then PasteFromClipboard; vk_Tab: TabIndent; vk_Divide, $BF: // $BF - VK_OEM_2, missing in D7 if (Shift = [ssCtrl]) then QuickComment; else MyKey := False; end; if Shift = [ssCtrl] then begin MyKey := True; if Key = 65 then // Ctrl+A Select all begin SelectAll; end else if Key = 89 then // Ctrl+Y Delete line begin if FText.Count > FPos.Y then begin FMoved := True; AddUndo; FText.Delete(FPos.Y - 1); CorrectBookmark(FPos.Y, -1); DoChange; end else if FText.Count = FPos.Y then begin FMoved := True; AddUndo; FText[FPos.Y - 1] := ''; FPos.X := 1; SetPos(FPos.X, FPos.Y); DoChange; end; ClearSyntax(FPos.Y); end else if Key in [48..57] then GotoBookmark(Key - 48) else if Key = 32 then // Ctrl+Space code completion begin if Assigned(FOnCodeCompletion) then DoCodeCompletion; MyKey := True; end else if Key = Ord('C') then begin CopyToClipboard; MyKey := True; end else if Key = Ord('V') then begin PasteFromClipboard; MyKey := True; end else if Key = Ord('X') then begin CutToClipboard; MyKey := True; end else if Key = Ord('I') then begin DoCtrlI; MyKey := True; end else if Key = Ord('U') then begin DoCtrlU; MyKey := True; end else if Key = Ord('Z') then begin Undo; MyKey := True; end; end; if Shift = [ssCtrl, ssShift] then begin MyKey := True; if Key in [48..57] then if IsBookmark(FPos.Y - 1) < 0 then AddBookmark(FPos.Y - 1, Key - 48) else if IsBookmark(FPos.Y - 1) = (Key - 48) then DeleteBookmark(Key - 48); end; if Key in [vk_Left, vk_Right, vk_Up, vk_Down, vk_Home, vk_End, vk_Prior, vk_Next] then begin FMoved := True; if ssShift in Shift then AddSel else ClearSel; end else if Key in [vk_Return, vk_Delete, vk_Back, vk_Insert, vk_Tab] then FMoved := True; if MyKey then Key := 0; end; procedure TfrxSyntaxMemo.KeyPress(var Key: Char); var MyKey, ControlKeyDown: Boolean; begin inherited; ControlKeyDown := (((GetKeyState(VK_LCONTROL) and not $7FFF) <> 0) or ((GetKeyState(VK_RCONTROL) and not $7FFF) <> 0)) and (GetKeyState(VK_RMENU) >= 0); MyKey := True; {$IFDEF Delphi12} if ((Key = #32) and not ControlKeyDown) or (CharInSet(Key, [#33..#255]) and not((Key = #127) and ControlKeyDown)) or IsUnicodeChar(Key) and not((Key = #127) and ControlKeyDown) then {$ELSE} if ((Key = #32) and not ControlKeyDown) or (Key in [#33..#255]) and not((Key = #127) and ControlKeyDown) then {$ENDIF} begin DoChar(Key); FMoved := False; end else MyKey := False; if MyKey then Key := #0; end; {$IFDEF FPC} procedure TfrxSyntaxMemo.UTF8KeyPress(var UTF8Key: TUTF8Char); begin {$note TODO: fix handling of UTF8 keys} inherited UTF8KeyPress(UTF8Key); SelText := String(UTF8Key); UTF8Key := ''; end; {$ENDIF} procedure TfrxSyntaxMemo.DoCodeCompletion; var p: TPoint; s: String; begin if IsCursorInStringBlock then Exit; FCompletionForm := TfrxPopupForm.Create(Self); FCompletionForm.Color := clSkyBlue; FCompletionForm.Resizable := True; FCompletionForm.OnClose := CompletionFormClose; FCompletionForm.Constraints.MinWidth := FCodeCompletionMinWidth; FCompletionForm.Constraints.MinHeight := FCodeCompletionMinHeight; FCodeCompList.Clear; FCompletionLB := TListBox.Create(FCompletionForm); FScriptCompletionList.Locked := True; with FCompletionLB do begin Parent := FCompletionForm; {$IFNDEF FPC} Ctl3D := False; {$ENDIF} Color := Self.Color; {$IFDEF FPC} ItemHeight := 16; Align := alClient; {$ELSE} Align := alNone; ItemHeight := ItemHeight + 2; {$ENDIF} Style := lbOwnerDrawFixed; Sorted := False; OnDblClick := CompletionLBDblClick; OnKeyDown := CompletionLBKeyDown; OnKeyPress := CompletionLBKeyPress; OnDrawItem := CompletionLBDrawItem; s := Trim(GetCompletionString(FPos)); FCompleationFilter := GetFilter(s); FStartCodeCompPos := FPos.X - Length(FCompleationFilter); if FCompleationFilter = s then s := ''; FAddonCompletionList.DestroyItems; if Assigned(FOnCodeCompletion) and (cltAddon in FShowInCodeComplition) then FOnCodeCompletion(s, FAddonCompletionList); BuildCClist(s, FCodeCompList); FilterCodeListBox(FCompleationFilter, FCompletionLB, FCodeCompList, @frxSynPos); p := Self.ClientToScreen( Point(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, FCharHeight * (FPos.Y - FOffset.Y))); FCompletionForm.SetBounds(p.X, p.Y, CodeCompletionWidth, CodeCompletionHeight); {$IFNDEF FPC} SetBounds(2, 2, CodeCompletionWidth - 4, CodeCompletionHeight - 4); Anchors := [akLeft, akTop, akRight, akBottom]; {$ENDIF} if FCompletionLB.Count > 0 then FCompletionForm.Show else CompletionClose; end; end; procedure TfrxSyntaxMemo.CompletionClose; var lForm: TCustomForm; begin { prevent access to FCompletionForm when form destroying } lForm := FCompletionForm; if (FCompletionForm = nil) or (csDestroying in FCompletionForm.ComponentState) then Exit; FCompletionForm := nil; FScriptCompletionList.Locked := False; lForm.Close; end; procedure TfrxSyntaxMemo.CompletionFormClose(Sender: TObject; var Action: TCloseAction); begin FCodeCompletionWidth := TForm(Sender).Width; FCodeCompletionHeight := TForm(Sender).Height; end; procedure TfrxSyntaxMemo.CompletionLBDblClick(Sender: TObject); var s, s1: String; i: Integer; stepBack: Boolean; Item: TfrxCompletionItem; begin if FCompletionLB.ItemIndex <> -1 then begin FSelStart.X := FPos.X - frxLength(FCompleationFilter); FSelStart.Y := FPos.Y; FSelEnd.X := GetIdentEnd(FStartCodeCompPos); FSelEnd.Y := FPos.Y; s := FCompletionLB.Items[FCompletionLB.ItemIndex]; Item := TfrxCompletionItem(FCompletionLB.Items.Objects[FCompletionLB.ItemIndex]); i := 2; {$IFDEF Delphi12} while (i <= Length(s)) and ((CharInSet(s[i], WordChars) or IsUnicodeChar(s[i]))) do {$ELSE} while (i <= frxLength(s)) and (frxGetSymbol(s, i) {$IFDEF FPC}[1]{$ENDIF} in WordChars) {$IFDEF FPC} or (Length(frxGetSymbol(s, i)) > 1){$ENDIF}do {$ENDIF} Inc(i); s1 := frxCopy(s, 1, i - 1); stepBack := (i <= frxLength(s)) and (frxGetSymbol(s, i) = '('); if stepBack then s1 := s1 + '()'; SelText := s1; s1 := ''; if stepBack then begin DoLeft; if Item.FParams <> '' then s1 := 'Parameters: (' + Item.FParams + ') '; end; if Item.FType <> '' then s1 := s1 + 'Type: ' + Item.FType; if s1 <> '' then ShowMessage(s1) end; CompletionClose; FCompleationFilter := ''; end; procedure TfrxSyntaxMemo.CompletionLBKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); var oldKey: Char; begin oldKey := Char(Key); if Key = VK_ESCAPE then CompletionClose else if (Key = VK_RETURN) or (key = 190) then CompletionLBDblClick(nil) else if not((Integer(Key) >= 0) and (Integer(Key) <= 48)) or (((Integer(Key) = VK_BACK) or (Integer(Key) = VK_LEFT)) and (FPos.X > FStartCodeCompPos)) or ((Integer(Key) = VK_RIGHT) and (FPos.X < GetIdentEnd(FStartCodeCompPos))) then KeyDown(Key, Shift); { update code compleation } if (Integer(oldKey) = VK_LEFT) or (Integer(oldKey) = VK_RIGHT) then CompletionLBKeyPress(Sender, oldKey); end; procedure TfrxSyntaxMemo.CompletionLBKeyPress(Sender: TObject; var Key: Char); var bLeftRightKey: Boolean; begin bLeftRightKey := (Key = Char(VK_LEFT)) or (Key = Char(VK_RIGHT)); if (Key >= #0) and (Key <= #48) and not((Key = Char(VK_BACK)) or bLeftRightKey) then Exit; if not bLeftRightKey then KeyPress(Key); FCompleationFilter := Trim(GetFilter(GetCompletionString(FPos))); FilterCodeListBox(FCompleationFilter, FCompletionLB, FCodeCompList, @frxSynPos); end; procedure TfrxSyntaxMemo.CompletionLBDrawItem(Control: TWinControl; Index: Integer; ARect: TRect; State: TOwnerDrawState); var i, w: Integer; s: String; Item: TfrxCompletionItem; begin with FCompletionLB.Canvas do begin FillRect(ARect); if Index <> -1 then begin Item := TfrxCompletionItem(FCompletionLB.Items.Objects[Index]); s := ''; Font.Color := clFuchsia; if Pos('Constructor', FCompletionLB.Items[Index]) <> 0 then s := 'constructor' else Font.Color := ItemToPrefix(Item, s, Font.Color); if odSelected in State then Font.Color := clWhite; Font.Style := []; TextOut(ARect.Left + 2, ARect.Top + 2, s); w := TextWidth('constructor '); Font.Color := clBlack; if odSelected in State then Font.Color := clWhite; Font.Style := [fsBold]; s := FCompletionLB.Items[Index]; i := 1; {$IFDEF Delphi12} while (i <= Length(s)) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do {$ELSE} while (i <= frxLength(s)) and (frxGetSymbol(s, i){$IFDEF FPC}[1]{$ENDIF} in WordChars) {$IFDEF FPC} or (Length(frxGetSymbol(s, i)) > 1){$ENDIF}do {$ENDIF} Inc(i); s := frxCopy(s, 1, i - 1); TextOut(ARect.Left + w + 6, ARect.Top + 2, s); w := w + TextWidth(s); Font.Style := []; s := Copy(FCompletionLB.Items[Index], i, 255); if Pos(': Constructor', s) <> 0 then s := Copy(s, 1, Pos(': Constructor', s) - 1); TextOut(ARect.Left + w + 6, ARect.Top + 2, s); end; end; end; function TfrxSyntaxMemo.ItemToPrefix(Item: TfrxCompletionItem; var pref: String; c: TColor = clNone): TColor; begin Result := c; case Item.FItemType of itVar: begin pref := 'var'; Result := clBlue; end; itProperty, itIndex: begin pref := 'property'; Result := clBlue; end; itProcedure: pref := 'procedure'; itFunction: pref := 'function'; itConstant: pref := 'constant'; itConstructor: pref:= 'constructor'; itType: begin pref := 'type'; Result := clBlack; end; itEvent: begin pref := 'event'; Result := clNavy; end; end; end; procedure TfrxSyntaxMemo.DoLeft; begin Dec(FPos.X); if FPos.X < 1 then FPos.X := 1; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoRight; begin Inc(FPos.X); if FPos.X > FMaxLength then FPos.X := FMaxLength; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoTimer(Sender: TObject); begin FTimer.Enabled := False; if csDestroying in ComponentState then Exit; FCodeCompletionThread.FMemoHandle := Handle; FCodeCompletionThread.Script := FScript; FCodeCompletionThread.FSyntaxType := Syntax; if FCodeCompletionThread.Suspended then FCodeCompletionThread.Resume; end; procedure TfrxSyntaxMemo.DoUp; begin Dec(FPos.Y); if FPos.Y < 1 then FPos.Y := 1; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoDown; begin Inc(FPos.Y); if FPos.Y > FText.Count then FPos.Y := FText.Count; SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoHome(Ctrl: Boolean); begin if Ctrl then SetPos(1, 1) else SetPos(1, FPos.Y); end; procedure TfrxSyntaxMemo.DoEnd(Ctrl: Boolean); begin if Ctrl then SetPos(LineLength(FText.Count - 1) + 1, FText.Count) else SetPos(LineLength(FPos.Y - 1) + 1, FPos.Y); end; procedure TfrxSyntaxMemo.DoPgUp; begin if FOffset.Y > FWindowSize.Y then begin Dec(FOffset.Y, FWindowSize.Y - 1); Dec(FPos.Y, FWindowSize.Y - 1); end else begin if FOffset.Y > 0 then begin Dec(FPos.Y, FOffset.Y); FOffset.Y := 0; end else FPos.Y := 1; end; SetPos(FPos.X, FPos.Y); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.DoPPIChanged(aNewPPI: Integer); begin inherited; FGutterWidth := MulDiv(FGutterWidth, aNewPPI, FfrCurrentPPI); Font.PixelsPerInch := aNewPPI; FCommentAttr.PixelsPerInch := aNewPPI; FKeywordAttr.PixelsPerInch := aNewPPI; FNumberAttr.PixelsPerInch := aNewPPI; FStringAttr.PixelsPerInch := aNewPPI; FTextAttr.PixelsPerInch := aNewPPI; end; procedure TfrxSyntaxMemo.DoPgDn; begin if FOffset.Y + FWindowSize.Y < FText.Count then begin Inc(FOffset.Y, FWindowSize.Y - 1); Inc(FPos.Y, FWindowSize.Y - 1); end else begin FOffset.Y := FText.Count; FPos.Y := FText.Count; end; SetPos(FPos.X, FPos.Y); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.DoReturn; var s: String; begin s := LineAt(FPos.Y - 1); FText[FPos.Y - 1] := frxCopy(s, 1, FPos.X - 1); FText.Insert(FPos.Y, frxCopy(s, FPos.X, FMaxLength)); EnterIndent; end; procedure TfrxSyntaxMemo.DoDel; var s: String; begin FMessage := ''; if FSelStart.X <> 0 then SelText := '' else begin s := FText[FPos.Y - 1]; AddUndo; if FPos.X <= LineLength(FPos.Y - 1) then begin frxDelete(s, FPos.X, 1); FText[FPos.Y - 1] := s; end else if FPos.Y < FText.Count then begin s := s + Pad(FPos.X - frxLength(s) - 1) + LineAt(FPos.Y); FText[FPos.Y - 1] := s; FText.Delete(FPos.Y); CorrectBookmark(FPos.Y, -1); end; UpdateScrollBar; ClearSyntax(FPos.Y); DoChange; end; end; procedure TfrxSyntaxMemo.DoBackspace; var s: String; begin FMessage := ''; if FSelStart.X <> 0 then SelText := '' else begin s := FText[FPos.Y - 1]; if FPos.X > 1 then begin if (GetLineBegin(FPos.Y - 1) = FPos.X) or (Trim(s) = '') then UnIndent else begin AddUndo; if Trim(s) <> '' then begin frxDelete(s, FPos.X - 1, 1); FText[FPos.Y - 1] := s; DoLeft; end else DoHome(False); ClearSyntax(FPos.Y); DoChange; end; end else if FPos.Y > 1 then begin AddUndo; CorrectBookmark(FPos.Y, -1); s := LineAt(FPos.Y - 2); FText[FPos.Y - 2] := s + FText[FPos.Y - 1]; FText.Delete(FPos.Y - 1); SetPos(Length(s) + 1, FPos.Y - 1); ClearSyntax(FPos.Y); DoChange; end; end; end; procedure TfrxSyntaxMemo.DoCtrlI; begin if FSelStart.X <> 0 then ShiftSelected(True); end; procedure TfrxSyntaxMemo.DoCtrlU; begin if FSelStart.X <> 0 then ShiftSelected(False); end; procedure TfrxSyntaxMemo.DoCtrlL; var i: Integer; s: String; begin s := FText.Text; i := frxLength(LineAt(FPos.Y - 1)); if FPos.X > i then FPos.X := i; i := GetPlainTextPos(FPos); Dec(i); {$IFDEF Delphi12} while (i > 0) and not ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do {$ELSE} while (i > 0) and not (frxGetSymbol(s, i){$IFDEF FPC}[1]{$ENDIF} in WordChars) {$IFDEF FPC}or (Length(frxGetSymbol(s, i)) > 1){$ENDIF}do {$ENDIF} if frxGetSymbol(s, i) = LineBreak[1] then break else Dec(i); {$IFDEF Delphi12} while (i > 0) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do {$ELSE} while (i > 0) and (frxGetSymbol(s, i){$IFDEF FPC}[1]{$ENDIF} in WordChars) {$IFDEF FPC}or (Length(frxGetSymbol(s, i)) > 1){$ENDIF}do {$ENDIF} Dec(i); Inc(i); FPos := GetPosPlainText(i); SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoCtrlR; var i: Integer; s: String; begin s := FText.Text; i := Length(LineAt(FPos.Y - 1)); if FPos.X > i then begin DoDown; DoHome(False); FPos.X := 1; Exit; end; i := GetPlainTextPos(FPos); {$IFDEF Delphi12} while (i < Length(s)) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do {$ELSE} while (i < frxLength(s)) and (frxGetSymbol(s, i){$IFDEF FPC}[1]{$ENDIF} in WordChars) {$IFDEF FPC}or (Length(frxGetSymbol(s, i)) > 1){$ENDIF}do {$ENDIF} Inc(i); {$IFDEF Delphi12} while (i < Length(s)) and not ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do {$ELSE} while (i < frxLength(s)) and not (frxGetSymbol(s, i){$IFDEF FPC}[1]{$ENDIF} in WordChars) {$IFDEF FPC}or (Length(frxGetSymbol(s, 1)) > 1){$ENDIF}do {$ENDIF} if frxGetSymbol(s, i) = LineBreak[1] then begin while (i > 1) and (frxGetSymbol(s, i - 1) = ' ') do Dec(i); break; end else Inc(i); FPos := GetPosPlainText(i); SetPos(FPos.X, FPos.Y); end; procedure TfrxSyntaxMemo.DoChar(Ch: Char); begin SelText := Ch; end; function TfrxSyntaxMemo.GetCharAttr(Pos: TPoint): TfrxCharAttributes; function IsBlock: Boolean; var p1, p2, p3: Integer; begin Result := False; if FSelStart.X = 0 then Exit; p1 := FSelStart.X + FSelStart.Y * FMaxLength; p2 := FSelEnd.X + FSelEnd.Y * FMaxLength; if p1 > p2 then begin p3 := p1; p1 := p2; p2 := p3; end; p3 := Pos.X + Pos.Y * FMaxLength; Result := (p3 >= p1) and (p3 < p2); end; function CharAttr: Byte; var s: TfrxByteArr; begin if Pos.Y - 1 < FSynAttributes.Count then begin s := FSynAttributes[Pos.Y - 1]; if Pos.X <= Length(s) then Result := s[Pos.X - 1] else Result := Ord(caText); end else Result := Ord(caText); end; begin Result.StyleIndex := CharAttr; Result.IsSelBlock := IsBlock; end; function TfrxSyntaxMemo.GetCompletionString(Pos: TPoint): String; var i: Integer; s: String; fl1, fl2: Boolean; fl3, fl4: Integer; begin Result := ''; s := LineAt(Pos.Y - 1, False); s := frxCopy(s, 1, Pos.X - 1); fl1 := False; fl2 := False; fl3 := 0; fl4 := 0; i := frxLength(s); while i >= 1 do begin if (frxGetSymbol(s, i) = ' ') then break else if (frxGetSymbol(s, i) = '''') and not fl2 then fl1 := not fl1 else if (frxGetSymbol(s, i) = '"') and not fl1 then fl2 := not fl2 else if not fl1 and not fl2 and (frxGetSymbol(s, i) = ')') then Inc(fl3) else if not fl1 and not fl2 and ((frxGetSymbol(s, i) = '(') or (frxGetSymbol(s, i) = ' ')) and (fl3 > 0) then Dec(fl3) else if not fl1 and not fl2 and (frxGetSymbol(s, i) = ']') then Inc(fl4) else if not fl1 and not fl2 and (frxGetSymbol(s, i) = '[') and (fl4 > 0) then Dec(fl4) else if not fl1 and not fl2 and (fl3 = 0) and (fl4 = 0) then {$IFDEF Delphi12} if CharInSet(s[i], ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', ' ']) or IsUnicodeChar(s[i]) then {$ELSE} if frxGetSymbol(s, i){$IFDEF FPC}[1]{$ENDIF} in ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', ' '] then {$ENDIF} Result := s[i] + Result else break; Dec(i); end; end; function TfrxSyntaxMemo.GetFilter(aStr: String): String; var i: Integer; begin Result := aStr; for i := Length(aStr) downto 1 do if aStr[i] = '.' then begin Result := Copy(aStr, i + 1, Length(aStr) - i); break; end; end; {$IFNDEF FPC} function TfrxSyntaxMemo.GetCharWidth(const Str: String): Integer; begin with FTmpCanvas.Canvas do begin Font.Assign(Self.Font); Result := TextWidth(Str); end; end; function TfrxSyntaxMemo.GetCharXPos(X: Integer): Integer; var s, s2: String; i: Integer; begin s := LineAt(FPos.Y - 1); s2 := ''; Result := 0; for i := FOffset.X + 1 to Length(s) do begin s2 := s2 + s[i]; if GetCharWidth(s2) >= x then begin Result := i; Exit; end; end; end; {$ENDIF} procedure TfrxSyntaxMemo.Paint; var i, j, j1: Integer; a, a1: TfrxCharAttributes; s: String; procedure SetAttr(a: TfrxCharAttributes; ALine: Integer); var Attr: TCharAttr; style: TfrxAttributeStyle; begin style := nil; with Canvas do begin Brush.Color := Color; if a.StyleIndex <= ReservedStylesCount then Attr := TCharAttr(a.StyleIndex) else begin style := AttributeStyles.GetStyleByID(a.StyleIndex); Attr := style.AttrType; end; case Attr of caNo: ; caText: Font.Assign(FTextAttr); caComment: Font.Assign(FCommentAttr); caKeyword: Font.Assign(FKeywordAttr); caString: Font.Assign(FStringAttr); caNumber: Font.Assign(FNumberAttr); end; if Assigned(style) then AttributeStyles.AssignStyle(style, Font); if a.IsSelBlock or (ALine = FActiveLine - 1) then begin Brush.Color := FBlockColor; Font.Color := FBlockFontColor; end; Font.Charset := Self.Font.Charset; end; end; procedure MyTextOut(x, y: Integer; const s: String); var i: Integer; begin if FIsMonoType then begin Canvas.FillRect(Rect(x, y, x + frxLength(s) * FCharWidth, y + FCharHeight)); Canvas.TextOut(x, y, s) end else with Canvas do begin FillRect(Rect(x, y, x + frxLength(s) * FCharWidth, y + FCharHeight)); if FMultiByteLang then Canvas.TextOut(x, y, s) else begin for i := 1 to frxLength(s) do TextOut(x + (i - 1) * FCharWidth, y, frxGetSymbol(s, i)); MoveTo(x + frxLength(s) * FCharWidth, y); end; end; end; procedure DrawLineMarks(ALine, Y: Integer); var s: String; tw, defGW, h: Integer; begin if not FShowGutter then Exit; Canvas.Brush.Color := clSkyBlue; Canvas.Pen.Color := clSkyBlue; h := MulDiv(4, FfrCurrentPPI, 96); Canvas.Ellipse(6, Y + 8, 6 + h, Y + 8 + h); if ((ALine + 1) mod 5 = 0) and FShowLineNumber then begin Canvas.Brush.Color := clBtnFace; Canvas.Font.Name := 'Tahoma'; Canvas.Font.Color := clSkyBlue; Canvas.Font.Style := []; Canvas.Font.Size := 8; Canvas.Font.Height := MulDiv(Canvas.Font.Height, FfrCurrentPPI, Canvas.Font.PixelsPerInch); s := IntToStr(ALine + 1); Canvas.TextOut(4, Y + 2, s); tw := Canvas.TextWidth(s) + 10; defGW := MulDiv(DefGutterWidth, FfrCurrentPPI, 96); if FGutterWidth < tw then FGutterWidth := Canvas.TextWidth(s) + 10 else if tw <= defGW then FGutterWidth := defGW; end; if IsBookmark(ALine) >= 0 then with Canvas do begin Font.Name := 'Tahoma'; Font.Color := clWhite; Font.Style := [fsBold]; Font.Size := 7; Canvas.Font.Height := MulDiv(Canvas.Font.Height, FfrCurrentPPI, Canvas.Font.PixelsPerInch); tw := MulDiv(10, FfrCurrentPPI, 96); h := MulDiv(11, FfrCurrentPPI, 96); Brush.Color := clBlack; FillRect(Rect(13, Y + 3, 13 + tw, Y + 3 + h)); Brush.Color := clGreen; FillRect(Rect(12, Y + 4, 12 + tw, Y + 4 + h)); TextOut(14, Y + 4, IntToStr(IsBookmark(ALine))); end; if RunLine[ALine + 1] then with Canvas do begin Brush.Color := clBlue; Pen.Color := clBlack; h := MulDiv(4, FfrCurrentPPI, 96); Ellipse(4, Y + 7, 4 + h, Y + 7 + h); Pixels[5, Y + 7] := clAqua; Pixels[4, Y + 8] := clAqua; end; if IsBreakPoint(ALine + 1) then with Canvas do begin if IsActiveBreakPoint(ALine + 1) then begin Brush.Color := clRed; Pen.Color := clRed; end else begin Brush.Color := clGray; Pen.Color := clBlack; end; h := MulDiv(11, FfrCurrentPPI, 96); Ellipse(2, Y + 4, 2 + h, Y + 4 + h); end; end; begin inherited; Canvas.Font.PixelsPerInch := Font.PixelsPerInch; with Canvas do begin Brush.Color := clBtnFace; FillRect(Rect(0, 0, FGutterWidth - 2, Height)); Pen.Color := clBtnHighlight; MoveTo(FGutterWidth - 4, 0); LineTo(FGutterWidth - 4, Height + 1); if FSynAttributes.Updating then Exit; CreateSynArray(FOffset.Y + FWindowSize.Y - 1); for i := FOffset.Y to FOffset.Y + FWindowSize.Y - 1 do begin if i >= FText.Count then break; s := FText[i]; PenPos := Point(FGutterWidth, (i - FOffset.Y) * FCharHeight); j1 := FOffset.X + 1; a := GetCharAttr(Point(j1, i + 1)); for j := j1 to FOffset.X + FWindowSize.X do begin if j > Length(s) then break; a1 := GetCharAttr(Point(j, i + 1)); if (a1.IsSelBlock <> a.IsSelBlock) or (a.StyleIndex <> a1.StyleIndex) then begin SetAttr(a, i); MyTextOut(PenPos.X, PenPos.Y, Copy(FText[i], j1, j - j1)); a := a1; j1 := j; end; end; SetAttr(a, i); MyTextOut(PenPos.X, PenPos.Y, Copy(s, j1, FMaxLength)); if (GetCharAttr(Point(1, i + 1)).IsSelBlock) or (i = FActiveLine - 1) then MyTextOut(PenPos.X, PenPos.Y, Pad(FWindowSize.X - Length(s) - FOffset.X + 3)); DrawLineMarks(i, PenPos.Y); end; if FMessage <> '' then begin Font.Name := 'Tahoma'; Font.Color := clWhite; Font.Style := [fsBold]; Font.Size := 8; Brush.Color := clMaroon; FillRect(Rect(0, ClientHeight - TextHeight('|') - 6, ClientWidth, ClientHeight)); TextOut(6, ClientHeight - TextHeight('|') - 5, FMessage); end; {$IFDEF NONWINFPC} if Visible and HandleAllocated and FCaretCreated then begin SetCaretPos(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, FCharHeight * (FPos.Y - 1 - FOffset.Y)); {$IFDEF LCLGTK2} ShowCaret(Self.Handle); {$ENDIF} end; {$ENDIF} end; end; procedure TfrxSyntaxMemo.ClearSyntax(ClearFrom: Integer); begin Dec(ClearFrom); if ClearFrom < 1 then ClearFrom := 1; //FUpdatingSyntax := True; while FSynAttributes.Count > ClearFrom - 1 do FSynAttributes.Delete(FSynAttributes.Count - 1); //FUpdatingSyntax := False; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.CreateSynArray(EndLine: Integer); begin if EndLine >= FText.Count then EndLine := FText.Count - 1; if EndLine <= FSynAttributes.Count - 1 then Exit; FAllowLinesChange := False; FParser.Text := FText.Text; try FSynAttributes.UpdateSyntax(EndLine, FText); finally FAllowLinesChange := True; end; end; procedure TfrxSyntaxMemo.UpdateView; begin Invalidate; end; procedure TfrxSyntaxMemo.MouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin VertPosition := VertPosition - SmallChange; end; procedure TfrxSyntaxMemo.MouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); begin VertPosition := VertPosition + SmallChange; end; procedure TfrxSyntaxMemo.SetShowGutter(Value: Boolean); begin FShowGutter := Value; if Value then FGutterWidth := MulDiv(DefGutterWidth, FfrCurrentPPI, 96) else FGutterWidth := 0; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.SetShowInCodeComplition( const Value: TfrxCompletionListTypes); begin FShowInCodeComplition := Value; if cltRtti in Value then FillRtti else FRttiCompletionList.DestroyItems; end; function TfrxSyntaxMemo.IsBookmark(Line: Integer): Integer; var i: Integer; begin Result := -1; for i := 0 to 9 do if FBookmarks[i] = Line then begin Result := i; break; end; end; procedure TfrxSyntaxMemo.AddBookmark(Line, Number: Integer); begin if Number < Length(FBookmarks) then begin FBookmarks[Number] := Line; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; end; procedure TfrxSyntaxMemo.DeleteBookmark(Number: Integer); begin if Number < Length(FBookmarks) then begin FBookmarks[Number] := -1; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; end; procedure TfrxSyntaxMemo.CorrectBookmark(Line, Delta: Integer); var i: Integer; begin if Delta = 0 then exit; CorrectBreakPoints(Line, Delta); for i := 0 to Length(FBookmarks) - 1 do if FBookmarks[i] >= Line then Inc(FBookmarks[i], Delta); end; procedure TfrxSyntaxMemo.GotoBookmark(Number : Integer); begin if Number < Length(FBookmarks) then if FBookmarks[Number] >= 0 then SetPos(0, FBookmarks[Number] + 1); end; function TfrxSyntaxMemo.GetRunLine(Index: Integer): Boolean; begin if (Index < 1) or (Index > FText.Count) then Result := False else Result := FText.Objects[Index - 1] = Pointer(1); end; procedure TfrxSyntaxMemo.SetRunLine(Index: Integer; const Value: Boolean); begin if (Index < 1) or (Index > FText.Count) then Exit; if Value then FText.Objects[Index - 1] := Pointer(1) else FText.Objects[Index - 1] := Pointer(0); end; procedure TfrxSyntaxMemo.FillRtti; var i, j: Integer; Params: String; v: TfsCustomVariable; begin if not(cltRtti in FShowInCodeComplition) or (FRttiCompletionList.Count > 0) then Exit; for i := 0 to FScript.Count - 1 do begin v := FScript.Items[i]; if v is TfsVariable then begin if v.Typ = fvtEnum then continue; if v.IsReadOnly then FRttiCompletionList.AddConstant(v.Name, v.TypeName) else FRttiCompletionList.AddVariable(v.Name, v.TypeName); end else if v is TfsClassVariable then begin FRttiCompletionList.AddClass(v.Name, v.TypeName); end else if v is TfsMethodHelper then begin Params := ''; for j:= 0 to v.Count - 1 do begin if j > 0 then Params := Params + ';'; Params := Params + v.Params[j].Name + ': ' + v.Params [j].TypeName; end; FRttiCompletionList.AddFunction(TfsMethodHelper(v).Name, TfsMethodHelper(v).TypeName, Params); end; end; end; function TfrxSyntaxMemo.Find(const SearchText: String; CaseSensitive: Boolean; var SearchFrom: Integer): Boolean; var i: Integer; s: String; begin i := 0; Result := False; if FText.Count > 1 then begin s := FText.Text; if SearchFrom = 0 then SearchFrom := 1; s := frxCopy(s, SearchFrom, frxLength(s) - SearchFrom + 1); if CaseSensitive then begin i := frxPos(SearchText, s); if i <> 0 then Result := True; end else begin i := frxPos(frxUpperCase(SearchText), frxUpperCase(s)); if i <> 0 then Result := True; end; end; if Result then begin Inc(SearchFrom, i); FSelStart := GetPosPlainText(SearchFrom - 1); FSelEnd := Point(FSelStart.X + frxLength(SearchText), FSelStart.Y); Inc(SearchFrom, frxLength(SearchText)); SetPos(FSelStart.X, FSelStart.Y); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; end; procedure TfrxSyntaxMemo.AddBreakPoint(Number: Integer; const Condition: String; const Special: String); var bp: TfrxBreakPoint; begin if (Number = -1) or (Number >= Lines.Count) or IsBreakPoint(Number) or (LineAt(Number - 1) = '') then Exit; bp := TfrxBreakPoint.Create; bp.FLine := Number; bp.Condition := Condition; bp.SpecialCondition := Special; bp.FEnabled := True; FBreakPoints.AddObject(IntToStr(Number), bp); {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; procedure TfrxSyntaxMemo.ToggleBreakPoint(Number: Integer; const Condition: String); begin if IsBreakPoint(Number) then DeleteBreakPoint(Number) else AddBreakPoint(Number, Condition, ''); end; procedure TfrxSyntaxMemo.DeleteBreakPoint(Number: Integer); var i: Integer; begin i := FBreakPoints.IndexOf(IntToStr(Number)); if i <> -1 then begin TObject(FBreakPoints.Objects[i]).Free; FBreakPoints.Delete(i); end; {$IFDEF FPC} frxUpdateControl(Self); {$ELSE} Repaint; {$ENDIF} end; function TfrxSyntaxMemo.IsBreakPoint(Number: Integer): Boolean; begin Result := FBreakPoints.IndexOf(IntToStr(Number)) <> -1; end; function TfrxSyntaxMemo.IsCursorInStringBlock: Boolean; var s: String; i, sPos: Integer; begin Result := False; s := LineAt(FPos.Y - 1); if Length(s) >= FPos.X then begin sPos := 1; for i := FPos.X downto 1 do if (s[i] = FParser.StringQuotes[1]) or (s[i] = FParser.StringQuotes[2]) then begin sPos := i; break; end; FParser.Text := s; FParser.Position := sPos; Result := (FParser.GetString <> ''); end; end; function TfrxSyntaxMemo.GetAttributeStyles: TfrxAttributeStyles; begin Result := FSynDialectStyles.ActiveStyles; end; procedure TfrxSyntaxMemo.QuickComment; var singleLine, selected: Boolean; i, y, x, x1, y1: Integer; commenting: Boolean; s: String; CL1: String; CL1L, buf: Integer; procedure swap; var bp: TPoint; begin bp := Self.SelStart; Self.SelStart := Self.SelEnd; Self.SelEnd := bp; end; begin //check Dialect CL1 := FParser.CommentLine1; CL1L := Length(CL1); if CL1L < 1 then Exit; //Add undo FMoved := True; AddUndo; //swap if need if (Self.SelStart.Y > Self.SelEnd.Y) then swap else if (Self.SelStart.Y = Self.SelEnd.Y) then if Self.SelStart.X > Self.SelEnd.X then swap; //initialization if (((Self.SelStart.X = 0) and (Self.SelStart.Y = 0)) or ((Self.SelEnd.X = 0) and (Self.SelEnd.Y = 0))) then begin singleLine := True; selected := False; end else begin singleLine := Self.SelStart.Y = Self.SelEnd.Y; selected := not singleLine or (Self.SelStart.X <> Self.SelEnd.X); end; commenting := singleLine; if (selected) then begin x := Self.SelStart.X; y := Self.SelStart.Y; x1 := Self.SelEnd.X; y1 := Self.SelEnd.Y; end else begin x := Self.GetPos.X; y := Self.GetPos.Y; x1 := x; y1 := y; end; //analyze "comment or uncomment" if singleLine then begin s := Self.FText[y - 1]; for i := 1 to Length(s) do begin if s[i] = CL1[1] then begin commenting := (Pos(CL1, S) <> i); break; end else if (s[i] <> ' ') then begin commenting := True; break; end; end; end else begin for i := y to y1 do begin s := Self.FText[i - 1]; if (Length(s) < CL1L) then begin commenting := True; break; end else if (Pos(CL1, S) <> 1) then begin commenting := True; break; end; end; end; //change text for i := y to y1 do begin s := Self.FText[i - 1]; if commenting then s := CL1 + s else begin if singleLine then buf := Pos(CL1, S) else buf := 1; Delete(s, buf, CL1L); end; Self.FText[i - 1] := s; end; //change car if ((singleLine) and (not selected)) then Self.SetPos(x, y + 1) else begin if singleLine then x := 1; Self.SelStart := Point(x, y); Self.SelEnd := Point(x1, y1); Self.SetPos(x1, y1); end; //Repaint DoChange; ClearSyntax(y); end; function TfrxSyntaxMemo.GetBreakPointCondition(Number: Integer): String; var i: Integer; begin Result := ''; i := FBreakPoints.IndexOf(IntToStr(Number)); if i <> -1 then Result := TfrxBreakPoint(FBreakPoints.Objects[i]).Condition; end; procedure TfrxSyntaxMemo.DeleteF4BreakPoints; var i: Integer; begin i := 0; while i < FBreakPoints.Count do if TfrxBreakPoint(FBreakPoints.Objects[i]).FSpecialCondition = 'F4' then begin TObject(FBreakPoints.Objects[i]).Free; FBreakPoints.Delete(i); end else Inc(i); end; procedure TfrxSyntaxMemo.CorrectBreakPoints(Line, Delta: Integer); var i, bPos: Integer; begin // FBreakPoints[FBreakPoints.IndexOfObject(TObject(Number))] for i := 0 to FBreakPoints.Count - 1 do begin bPos := TfrxBreakPoint(FBreakPoints.Objects[i]).FLine; if bPos >= Line then begin Inc(bPos, Delta); TfrxBreakPoint(FBreakPoints.Objects[i]).FLine := bPos; FBreakPoints[i] := IntToStr(bPos); end; end; end; function TfrxSyntaxMemo.GetTextSelected: Boolean; begin // Result := True;// FSelStart end; function TfrxSyntaxMemo.GetBreakPointSpecialCondition( Number: Integer): String; var i: Integer; begin Result := ''; i := FBreakPoints.IndexOf(IntToStr(Number)); if i <> -1 then Result := TfrxBreakPoint(FBreakPoints.Objects[i]).FSpecialCondition; end; function TfrxSyntaxMemo.GetIdentEnd(aPos: Integer): Integer; var s: String; begin Result := aPos; s := LineAt(FPos.Y - 1); if Length(s) >= aPos then begin FParser.Text := s; FParser.Position := aPos;//GetPlainTextPos(Point(aPos, FPos.Y)); Result := Result + Length(FParser.GetIdent); end; end; procedure TfrxSyntaxMemo.ClearBreakPoints; var i: Integer; begin for i := 0 to FBreakPoints.Count - 1 do TObject(FBreakPoints.Objects[i]).Free; FBreakPoints.Clear; end; function TfrxSyntaxMemo.IsActiveBreakPoint(Number: Integer): Boolean; var i: Integer; begin Result := False; i := FBreakPoints.IndexOf(IntToStr(Number)); if i <> -1 then Result := TfrxBreakPoint(FBreakPoints.Objects[i]).FEnabled; end; procedure TfrxSyntaxMemo.AddNewBreakPoint; begin AddBreakPoint(FPos.Y, '', ''); end; procedure TfrxSyntaxMemo.LoadFromIni(const IniPath: String; const Section: String; const FileName: String); var i, nCount: Integer; BPIni: TCustomIniFile; sName: String; begin ClearBreakPoints; {$IFNDEF FPC} if Pos('\Software\', IniPath) = 1 then begin BPIni := TRegistryIniFile.Create(IniPath); // TRegistryIniFile(BPIni).RegIniFile.OpenKey(Section, False); end else {$ENDIF} BPIni := TIniFile.Create(IniPath); FSynDialectStyles.LoadFrom(Section + '\SQLDialects', BPIni); sName := Section + '\BreakPoints\' + FileName; nCount := BPIni.ReadInteger(sName, 'Count', 0); try for i := 0 to nCount - 1 do begin sName := Section + '\BreakPoints\' + FileName + '\BP' + IntToStr(i); AddBreakPoint(BPIni.ReadInteger(sName, 'Line', -1), BPIni.ReadString(sName, 'Condition', ''), ''); if BreakPoints.Count > 0 then TfrxBreakPoint(BreakPoints.Objects[BreakPoints.Count -1]).Enabled := BPIni.ReadBool(sName, 'Enabled', False); end; finally BPIni.Free; end; end; procedure TfrxSyntaxMemo.SaveToIni(const IniPath: String; const Section: String; const FileName: String); var BPStr, sName: String; BP: TfrxBreakPoint; i: Integer; BPIni: TCustomIniFile; begin {$IFNDEF FPC} if Pos('\Software\', IniPath) = 1 then BPIni := TRegistryIniFile.Create(IniPath) else {$ENDIF} BPIni := TIniFile.Create(IniPath); try sName := Section + '\BreakPoints\' + FileName; FSynDialectStyles.SaveTo(Section + '\SQLDialects', BPIni); BPIni.EraseSection(sName); BPIni.WriteInteger(sName, 'Count', BreakPoints.Count); for i := 0 to BreakPoints.Count - 1 do begin BP := TfrxBreakPoint(BreakPoints.Objects[i]); BPStr := sName + '\BP' + IntToStr(i); BPIni.WriteString(BPStr, 'Condition', BP.Condition); BPIni.WriteBool(BPStr, 'Enabled', BP.Enabled); BPIni.WriteInteger(BPStr, 'Line', BP.Line); end; finally BPIni.Free; end; end; { TfrxCompletionList } function TfrxCompletionList.AddBaseVar(varList: TStrings; const Name, sType: String; VisibleStart, VisibleEnd: Integer; const ParentFunc: String): TfrxCompletionItem; var Index: Integer; begin Index := varList.IndexOf(Name); if Index <> -1 then begin Result := TfrxCompletionItem(varList.Objects[Index]); Exit; end; Result := TfrxCompletionItem.Create; Result.FType := sType; Result.FStartVisible := VisibleStart; Result.FEndVisible := VisibleEnd; Result.FName := Name; if ParentFunc <> '' then begin Index := FFunctions.IndexOf(ParentFunc); if Index <> -1 then Result.FParent := TfrxCompletionItem(FFunctions.Objects[Index]); end; varList.AddObject(Name, Result); end; function TfrxCompletionList.AddClass(const Name, sType: String; VisibleStart, VisibleEnd: Integer; const ParentFunc: String): TfrxCompletionItem; begin Result := AddBaseVar(FClasses, Name, sType, VisibleStart, VisibleEnd ,ParentFunc); Result.FItemType := itType; end; function TfrxCompletionList.AddConstant(const Name, sType: String; VisibleStart, VisibleEnd: Integer; const ParentFunc: String): TfrxCompletionItem; begin Result := AddBaseVar(FConstants, Name, sType, VisibleStart, VisibleEnd ,ParentFunc); Result.FItemType := itConstant; end; function TfrxCompletionList.AddFunction(const Name, sType, Params: String; VisibleStart, VisibleEnd: Integer; const ParentFunc: String): TfrxCompletionItem; var Item: TfrxCompletionItem; begin Item := AddBaseVar(FFunctions, Name, sType, VisibleStart, VisibleEnd ,ParentFunc); Item.FParams := Params; if sType = '' then Item.FItemType := itProcedure else if SameText(Name, 'create') then Item.FItemType := itConstructor else Item.FItemType := itFunction; Result := Item; end; function TfrxCompletionList.AddVariable(const Name, sType: String; VisibleStart, VisibleEnd: Integer; const ParentFunc: String): TfrxCompletionItem; begin Result := AddBaseVar(FVariables, Name, sType, VisibleStart, VisibleEnd ,ParentFunc); if CompareText(Name, sType) = 0 then Result.FItemType := itType else Result.FItemType := itVar; end; function TfrxCompletionList.Count: Integer; begin Result := FConstants.Count + FVariables.Count + FFunctions.Count + FClasses.Count; end; constructor TfrxCompletionList.Create; begin FConstants := TStringList.Create; FConstants.Sorted := True; FVariables := TStringList.Create; FVariables.Sorted := True; FFunctions := TStringList.Create; FFunctions.Sorted := True; FClasses := TStringList.Create; FClasses.Sorted := True; end; destructor TfrxCompletionList.Destroy; begin DestroyItems; FreeAndNil(FConstants); FreeAndNil(FVariables); FreeAndNil(FFunctions); FreeAndNil(FClasses); end; procedure TfrxCompletionList.DestroyItems; procedure FreeList(sl: TStrings); var i: Integer; begin for i := 0 to sl.Count - 1 do TfrxCompletionItem(sl.Objects[i]).Free; sl.Clear; end; begin if FLocked then Exit; FreeList(FConstants); FreeList(FVariables); FreeList(FFunctions); FreeList(FClasses); end; function TfrxCompletionList.Find(const Name: String): TfrxCompletionItem; var Index: Integer; begin Result := nil; if FConstants.Find(Name, Index) then Result := TfrxCompletionItem(FConstants.Objects[Index]) else if FVariables.Find(Name, Index) then Result := TfrxCompletionItem(FVariables.Objects[Index]) else if FFunctions.Find(Name, Index) then Result := TfrxCompletionItem(FFunctions.Objects[Index]) else if FClasses.Find(Name, Index) then Result := TfrxCompletionItem(FClasses.Objects[Index]); end; function TfrxCompletionList.GetItem(Index: Integer): TfrxCompletionItem; begin Result := nil; if Index < 0 then Exit; if FConstants.Count > Index then begin Result := TfrxCompletionItem(FConstants.Objects[Index]); Exit; end; Dec(Index, FConstants.Count); if FVariables.Count > Index then begin Result := TfrxCompletionItem(FVariables.Objects[Index]); Exit; end; Dec(Index, FVariables.Count); if FFunctions.Count > Index then begin Result := TfrxCompletionItem(FFunctions.Objects[Index]); Exit; end; Dec(Index, FFunctions.Count); if FClasses.Count > Index then Result := TfrxCompletionItem(FClasses.Objects[Index]); end; { TfrxCodeCompletionThread } destructor TfrxCodeCompletionThread.Destroy; begin FText := nil; inherited; FreeScript; end; procedure TfrxCodeCompletionThread.Execute; begin while not Terminated do begin // synch via messages is not tested on Lazarus {$IFDEF FPC} Synchronize(SyncScript); {$ELSE} SendMessage(FMemoHandle, WM_FRX_SYNC_SCRIPT, 0, 0); {$ENDIF} if Assigned(FScript) and not Terminated then begin FILCode := TMemoryStream.Create; {$IFDEF FPC} Synchronize(UpdateCode); {$ELSE} SendMessage(FMemoHandle, WM_FRX_UPDATE_CODE, 0, 0); {$ENDIF} try if FScript.GetILCode(FILCode) and not Terminated then begin FXML := TfsXMLDocument.Create; FILCode.Position := 0; FXML.LoadFromStream(FILCode); {$IFDEF FPC} Synchronize(FillCodeCompletion); {$ELSE} SendMessage(FMemoHandle, WM_FRX_FILL_CODE_COMPLETION, 0, 0); {$ENDIF} FreeAndNil(FXML); end; except end; FreeAndNil(FILCode); end; // just in case if not Terminated then Suspend; end; end; procedure TfrxCodeCompletionThread.FillCodeCompletion; var Prog: TfsXMLItem; function GetLine(const s: String): Integer; var Index: Integer; ss: String; begin Result := 0; Index := Pos(':', s); if Index > 1 then begin ss := Copy(s, 1, Index - 1); if ss <> '' then Result := StrToInt(ss); end; end; function DoAddV(sItem: TfsXMLItem; pStart, pEnd: Integer): String; var i: Integer; Name, sType: String; lTypFixup: TList; begin Result := ''; if (CompareText(sItem.Name, 'var') = 0) then begin lTypFixup := TList.Create; try for i := 0 to sItem.Count - 1 do if (CompareText(sItem.Items[i].Name, 'ident') = 0) then begin Name := sItem.Items[i].Prop['text']; if Result <> '' then Result := Result + ' ,'; Result := Result + Name; lTypFixup.Add(FCompletionList.AddVariable(Name, sType, pStart, pEnd)); end else if (CompareText(sItem.Items[i].Name, 'type') = 0) then sType := sItem.Items[i].Prop['text']; Result := Result + ': ' + sType; for i := 0 to lTypFixup.Count - 1 do TfrxCompletionItem(lTypFixup[i]).FType := sType; finally lTypFixup.Free; end; end; end; function GetLastPos(sItem: TfsXMLItem): String; var s: String; begin Result := sItem.Prop['pos']; if (CompareText(sItem.Name, 'compoundstmt') = 0) and (sItem.Count > 0) then s := GetLastPos(sItem.Items[sItem.Count - 1]); if s <> '' then Result := s; end; procedure DoAddVar(sItem: TfsXMLItem; pStart, pEnd: Integer); var i, nStart: Integer; s, s1, sTyp: String; bNextIsVar: Boolean; TypItem: TfsXMLItem; begin nStart := 0; sTyp := ''; if (CompareText(sItem.Name, 'procedure') = 0) or (CompareText(sItem.Name, 'function') = 0) then begin s := sItem.Prop['pos']; pStart := GetLine(s); s1 := sItem.Items[0].Prop['text']; if (CompareText(sItem.Items[1].Name, 'parameters') = 0) then begin s := GetLastPos(sItem.Items[sItem.Count - 1]); pEnd := GetLine(s) + 1; s := ''; bNextIsVar := False; for i := 0 to sItem.Items[1].Count - 1 do begin if bNextIsVar then s := s + ' var ' else if i > 0 then s := s + ';'; bNextIsVar := (CompareText(sItem.Items[1].Items[i].Name, 'varparams') = 0); if bNextIsVar then continue; s := s + DoAddV(sItem.Items[1].Items[i], pStart, pEnd); end; nStart := 2; end; TypItem := sItem.FindItem('type'); if Assigned(TypItem) then sTyp := TypItem.Prop['text']; if s <> '' then FCompletionList.AddFunction(s1, sTyp, s, pStart); end else if (CompareText(sItem.Name, 'var') = 0) then DoAddV(sItem, pStart, pEnd); for i := nStart to sItem.Count - 1 do DoAddVar(sItem.Items[i], pStart, pEnd); end; begin if not Assigned(FXML) or FCompletionList.Locked then Exit; Prog := FXML.Root.FindItem('program'); FCompletionList.DestroyItems; if Assigned(Prog) then DoAddVar(FXML.Root, 0, -1); end; procedure TfrxCodeCompletionThread.FreeScript; var pScript, lScript: TfsScript; begin if not Assigned(FScript) then Exit; pScript := FScript.Parent; while pScript <> nil do begin lScript := pScript; pScript := pScript.Parent; FreeAndNil(lScript); end; FreeAndNil(FScript); end; procedure TfrxCodeCompletionThread.SyncScript; var pScript, lScript: TfsScript; begin if Assigned(FScript) or not Assigned(FOriginalScript) then Exit; FScript := TfsScript.Create(nil); FScript.SyntaxType := FSyntaxType; pScript := FOriginalScript.Parent; { do not process GlobalUnit } if Assigned(pScript) and (fsIsGlobalUnitExist) and (pScript = fsGlobalUnit) then pScript := nil; lScript := FScript; lScript.AddRTTI; while pScript <> nil do begin pScript := pScript.Parent; if Assigned(pScript) and (fsIsGlobalUnitExist) and (pScript = fsGlobalUnit) then break; lScript.Parent := TfsScript.Create(nil); lScript := lScript.Parent; lScript.Lines.Assign(pScript.Lines); lScript.SyntaxType := FSyntaxType; lScript.AddRTTI; end; end; procedure TfrxCodeCompletionThread.UpdateCode; begin if Assigned(FScript) and Assigned(FText) then FScript.Lines.Assign(FText); if Assigned(FScript) and Assigned(FOriginalScript) then FScript.SyntaxType := FSyntaxType; end; { TfrxSynAttributes } procedure TfrxSynAttributes.ActiveChanged(Sender: TObject); begin UpdateSyntaxDialect; end; constructor TfrxSynAttributes.Create(Parser: TfsParser; DialectStyles: TfrxSynDialectStyles); begin FParser := Parser; FDialectStyles := DialectStyles; FDialectStyles.OnActiveChanged := ActiveChanged; end; procedure TfrxSynAttributes.Delete(Index: Integer); begin FUpdating := True; if (Index < 0) or (Index >= FCount) then raise Exception.Create('Error Message'); Finalize(FArray[Index]); Dec(FCount); if Index < FCount then begin System.Move(FArray[Index + 1], FArray[Index], (FCount - Index) * SizeOf(TfrxByteArr)); end; FUpdating := False; end; function TfrxSynAttributes.GetAllAttributes: TfrxByteArr; var Len, i: Integer; begin Len := 0; for i := 0 to FCount - 1 do Inc(Len, Length(FArray[i]) + Length(sLineBreak)); SetLength(Result, Len); Len := 0; for i := 0 to FCount - 1 do begin Move(FArray[i][0], Result[Len], Length(FArray[i])); Inc(Len, Length(FArray[i]) + Length(sLineBreak)); Result[Len - 1] := 0; Result[Len - 2] := 0; end; end; function TfrxSynAttributes.GetLine(Index: Integer): TfrxByteArr; begin Result := FArray[Index]; end; procedure TfrxSynAttributes.PutLine(Index: Integer; const Value: TfrxByteArr); begin FArray[Index] := Value; end; procedure TfrxSynAttributes.SetAllAttributes(Attr: TfrxByteArr); var i, Index, Len, sLen: Integer; begin Len := Length(Attr); Index := 0; for i := 0 to FCount - 1 do begin if Len - Length(FArray[i]) > 0 then sLen := Length(FArray[i]) else sLen := Len; Move(Attr[Index], FArray[i][0], sLen); Inc(Index, sLen + Length(sLineBreak)); Dec(Len, sLen + Length(sLineBreak)); end; end; procedure TfrxSynAttributes.SetCapacity(NewCapacity: Integer); begin if NewCapacity < FCount then raise Exception.CreateFmt('Invalid Capacity %d', [NewCapacity]); if NewCapacity <> FCapacity then begin SetLength(FArray, NewCapacity); FCapacity := NewCapacity; end; end; procedure TfrxSynAttributes.SetCount(NewCount: Integer); begin if NewCount < 0 then raise Exception.CreateFmt('Invalid count %d', [NewCount]); if NewCount <> FCount then begin if NewCount > FCapacity then SetCapacity(NewCount); FCount := NewCount; end;; end; procedure TfrxSynAttributes.SetLineLen(Index, NewLen: Integer); begin SetLength(FArray[Index], NewLen); FillChar(FArray[Index][0], NewLen, 255); end; procedure TfrxSynAttributes.UpdateSyntax(EndLine: Integer; Text: TStringList); var i, j, n, Max: Integer; FSyn: TfrxByteArr; s: String; attr: Byte; begin FUpdating := True; n := Count; Count := EndLine + 1; for i := n to EndLine do SetLineLen(i, Length(Text[i])); FSyn := GetAllAttributes; Max := Length(FSyn); for i := Length(FSyn) - 1 downto 0 do if Integer(FSyn[i]) = Ord(caText) then begin j := i; while (j > 1) and (Integer(FSyn[j]) = Ord(caText)) do Dec(j); FParser.Position := j + 1; break; end; while FParser.Position < Max do begin n := FParser.Position; FParser.SkipSpaces; for i := n to FParser.Position - 1 do if i <= Max then if FSyn[i - 1] > 31 then FSyn[i - 1] := Ord(caComment); attr := Ord(caText); n := FParser.Position; s := FParser.GetWord; if s <> '' then begin if FParser.IsKeyword(s) then attr := FDialectStyles.ActiveStyles.FindStyleIDByKeyword(s, caKeyword) else attr := FDialectStyles.ActiveStyles.FindStyleIDByKeyword(s, caText); end else begin s := FParser.GetNumber; if s <> '' then attr := Ord(caNumber) else begin s := FParser.GetString; if s <> '' then attr := Ord(caString) else FParser.Position := FParser.Position + 1 end end; for i := n to FParser.Position - 1 do if i <= Max then if FSyn[i - 1] > 31 then FSyn[i - 1] := Ord(attr); end; SetAllAttributes(FSyn); FUpdating := False; end; procedure TfrxSynAttributes.UpdateSyntaxDialect; var sl: TStringList; Dialect: TfrxSynDialectStyle; begin sl := TStringList.Create; Dialect := FDialectStyles.ActiveDialicet; if Dialect.Keywords <> '' then sl.CommaText := Dialect.Keywords else sl.CommaText := SQLKeywords; FParser.Keywords.Assign(sl); sl.Free; if Dialect.CommentLine1 <> '' then FParser.CommentLine1 := Dialect.CommentLine1 else FParser.CommentLine1 := SQLCommentLine1; FParser.CommentLine2 := Dialect.CommentLine2; if Dialect.CommentBlock1 <> '' then FParser.CommentBlock1 := Dialect.CommentBlock1 else FParser.CommentBlock1 := SQLCommentBlock1; FParser.CommentBlock2 := Dialect.CommentBlock2; if Dialect.StringQuotes <> '' then FParser.StringQuotes := Dialect.StringQuotes else FParser.StringQuotes := SQLStringQuotes; if Dialect.HexSequence <> '' then FParser.HexSequence := Dialect.HexSequence else FParser.HexSequence := SQLHexSequence; while Count > 0 do Delete(Count - 1); end; { TfrxAttributeStyles } function TfrxAttributeStyles.Add: TfrxAttributeStyle; begin Result := inherited Add as TfrxAttributeStyle; end; procedure TfrxAttributeStyles.AssignStyle(aStyle: TfrxAttributeStyle; aFont: TFont); begin aFont.Color := aStyle.FontColor; aFont.Style := aStyle.FontStyle; end; procedure TfrxAttributeStyles.AssignStyleByID(ID: Byte; aFont: TFont); var style: TfrxAttributeStyle; begin style := GetStyleByID(ID); AssignStyle(style, aFont); end; constructor TfrxAttributeStyles.Create; begin inherited Create(TfrxAttributeStyle); FDefaultAttribute := TfrxAttributeStyle.Create(nil); FIndexedList := TStringList.Create; FIndexedList.Sorted := True; end; destructor TfrxAttributeStyles.Destroy; begin inherited; FreeAndNil(FDefaultAttribute); FreeAndNil(FIndexedList); end; function TfrxAttributeStyles.FindStyleIDByKeyword(const Name: String; AttrType: TCharAttr): Byte; var i, Index: Integer; begin Result := ord(AttrType); for i := 0 to Count - 1 do if Items[i].AttrType = AttrType then begin Index := Items[i].FKeywords.IndexOf(Name); if Index > -1 then begin Result := Items[i].StyleID; break; end; end; end; function TfrxAttributeStyles.GetItem(Index: Integer): TfrxAttributeStyle; begin Result := TfrxAttributeStyle(inherited GetItem(Index)); end; function TfrxAttributeStyles.GetStyleByID(ID: Byte): TfrxAttributeStyle; var i: Integer; begin Result := FDefaultAttribute; i := FIndexedList.IndexOf(IntToStr(ID)); if i > -1 then Result := TfrxAttributeStyle(FIndexedList.Objects[i]); end; function TfrxAttributeStyles.GetUniqueID: Byte; var i: Integer; begin Result := Byte(High(TCharAttr)) + 1; for i := 0 to Count - 1 do begin if Result = Items[i].StyleID then Inc(Result); end; if Result >= 200 then raise Exception.Create('Collection is full.'); end; { TfrxAttributeStyle } constructor TfrxAttributeStyle.Create(Collection: TCollection); begin inherited Create(Collection); FKeywords := TStringList.Create; TStringList(FKeywords).Sorted := True; end; destructor TfrxAttributeStyle.Destroy; begin FreeAndNil(FKeywords); inherited; end; procedure TfrxAttributeStyle.SetCollection(Value: TCollection); var ACol: TfrxAttributeStyles; i: Integer; begin ACol := Value as TfrxAttributeStyles; if Assigned(ACol) then begin FStyleID := ACol.GetUniqueID; if Assigned(ACol.FIndexedList) then ACol.FIndexedList.AddObject(IntToStr(StyleID), Self); end else begin ACol := Collection as TfrxAttributeStyles; if Assigned(ACol) and Assigned(ACol.FIndexedList) then begin i := ACol.FIndexedList.IndexOf(IntToStr(StyleID)); if i > -1 then ACol.FIndexedList.Delete(i); end; end; inherited; end; { TfrxSynDialectStyle } constructor TfrxSynDialectStyle.Create(AOwner: TObject); begin FAttributeStyles := TfrxAttributeStyles.Create; FKeywords := SQLKeywords; FCommentLine1 := SQLCommentLine1; FCommentLine2 := ''; FCommentBlock1 := SQLCommentBlock1; FCommentBlock2 := ''; FStringQuotes := SQLStringQuotes; FHexSequence := SQLHexSequence; FOwner := AOwner; end; destructor TfrxSynDialectStyle.Destroy; begin FreeAndNil(FAttributeStyles); if Assigned(FOwner) and (FOwner is TfrxSynDialectStyles) then TfrxSynDialectStyles(FOwner).FLIst.Remove(Self); inherited; end; procedure TfrxSynDialectStyle.LoadFrom(const Section: String; Ini: TObject); var IniFile: TCustomIniFile absolute Ini; i, nCount: Integer; Style: TfrxAttributeStyle; sName: String; begin FKeywords := IniFile.ReadString(Section, 'Keywords', SQLKeywords); CommentLine1 := IniFile.ReadString(Section, 'CommentLine1', SQLCommentLine1); CommentLine2 := IniFile.ReadString(Section, 'CommentLine2', ''); CommentBlock1 := IniFile.ReadString(Section, 'CommentBlock1', SQLCommentBlock1); CommentBlock2 := IniFile.ReadString(Section, 'CommentBlock2', ''); StringQuotes := IniFile.ReadString(Section, 'StringQuotes', SQLStringQuotes); HexSequence := IniFile.ReadString(Section, 'HexSequence', SQLHexSequence); Name := IniFile.ReadString(Section, 'Name', ''); nCount := IniFile.ReadInteger(Section + '\AttributeStyles', 'Count', 0); for i := 0 to nCount - 1 do begin sName := Section + '\AttributeStyles\Style.' + IntToStr(i); Style := AttributeStyles.Add; Style.AttrType := TCharAttr(IniFile.ReadInteger(sName, 'AttrType', 0)); Style.Keywords.CommaText := IniFile.ReadString(sName, 'Keywords', ''); Style.FontColor := IniFile.ReadInteger(sName, 'FontColor', 0); Style.FontStyle := TFontStyles({$IFNDEF FPC}Byte{$ENDIF}(IniFile.ReadInteger(sName, 'FontStyle', 0))); end; end; procedure TfrxSynDialectStyle.SaveTo(const Section: String; Ini: TObject); var IniFile: TCustomIniFile absolute Ini; i: Integer; sName, sStr: String; Style: TfrxAttributeStyle; begin if (Keywords <> '') and (Keywords <> SQLKeywords) then IniFile.WriteString(Section, 'Keywords', Keywords); if (CommentLine1 <> '') and (CommentLine1 <> SQLCommentLine1) then IniFile.WriteString(Section, 'CommentLine1', CommentLine1); if CommentLine2 <> '' then IniFile.WriteString(Section, 'CommentLine2', CommentLine2); if (CommentBlock1 <> '') and (CommentBlock1 <> SQLCommentBlock1) then IniFile.WriteString(Section, 'CommentBlock1', CommentBlock1); if CommentBlock2 <> '' then IniFile.WriteString(Section, 'CommentBlock2', CommentBlock2); if (StringQuotes <> '') and (StringQuotes <> SQLStringQuotes) then IniFile.WriteString(Section, 'StringQuotes', StringQuotes); if (HexSequence <> '') and (HexSequence <> SQLHexSequence) then IniFile.WriteString(Section, 'HexSequence', HexSequence); IniFile.WriteString(Section, 'Name', Name); sName := Section + '\AttributeStyles'; IniFile.EraseSection(sName); IniFile.WriteInteger(sName, 'Count', AttributeStyles.Count); for i := 0 to AttributeStyles.Count - 1 do begin Style := AttributeStyles.Items[i]; sStr := sName + '\Style.' + IntToStr(i); IniFile.WriteInteger(sStr, 'AttrType', Integer(Style.AttrType)); IniFile.WriteString(sStr, 'Keywords', Style.Keywords.CommaText); IniFile.WriteInteger(sStr, 'FontColor', Style.FontColor); IniFile.WriteInteger(sStr, 'FontStyle', {$IFNDEF FPC}Byte{$ELSE}Integer{$ENDIF}(Style.FontStyle)); end; end; procedure TfrxSynDialectStyle.SetName(const Value: String); begin FName := Value; end; { TfrxSynDialectStyles } function TfrxSynDialectStyles.Add: TfrxSynDialectStyle; begin Result := TfrxSynDialectStyle.Create(Self); FLIst.Add(Result); end; procedure TfrxSynDialectStyles.Clear; var i: Integer; begin for i := FLIst.Count - 1 downto 0 do TObject(FLIst[i]).Free; FLIst.Clear; end; function TfrxSynDialectStyles.Count: Integer; begin Result := FLIst.Count; end; constructor TfrxSynDialectStyles.Create; begin FLIst := TList.Create; FDefSynDialectStyle := TfrxSynDialectStyle.Create(nil); FActiveIndex := -1; end; destructor TfrxSynDialectStyles.Destroy; begin Clear; FreeAndNil(FLIst); FreeAndNil(FDefSynDialectStyle); inherited; end; function TfrxSynDialectStyles.GetActiveDialicet: TfrxSynDialectStyle; begin if FActiveIndex > -1 then Result := Items[FActiveIndex] else Result := FDefSynDialectStyle; end; function TfrxSynDialectStyles.GetActiveStyles: TfrxAttributeStyles; begin if FActiveIndex > -1 then Result := Items[FActiveIndex].AttributeStyles else Result := FDefSynDialectStyle.AttributeStyles; end; function TfrxSynDialectStyles.GetItem(Index: Integer): TfrxSynDialectStyle; begin Result := TfrxSynDialectStyle(FLIst[Index]); end; procedure TfrxSynDialectStyles.LoadFrom(const Section: String; Ini: TObject); var IniFile: TCustomIniFile absolute Ini; i, nCount: Integer; begin Clear; nCount := IniFile.ReadInteger(Section, 'Count', 0); for i := 0 to nCount - 1 do Add.LoadFrom(Section + '\SQL.' + IntToStr(i), Ini); end; procedure TfrxSynDialectStyles.SaveTo(const Section: String; Ini: TObject); var IniFile: TCustomIniFile absolute Ini; i: Integer; sName: String; Style: TfrxSynDialectStyle; begin IniFile.WriteInteger(Section, 'Count', FLIst.Count); for i := 0 to FLIst.Count - 1 do begin Style := TfrxSynDialectStyle(FLIst[i]); sName := Section + '\SQL.' + IntToStr(i); IniFile.EraseSection(sName); Style.SaveTo(sName, Ini); end; end; procedure TfrxSynDialectStyles.SetActiveIndex(const Value: Integer); begin FActiveIndex := Value; if Assigned(FActiveChanged) then FActiveChanged(Self); end; end.