Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_2022_VCL/Source/frxSynMemo.pas
Daso e6303fc1c0 Inicijalizacija
2024-01-01 16:13:08 +01:00

4648 lines
121 KiB
ObjectPascal
Raw Permalink Blame History

{******************************************}
{ }
{ 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', '<27>'..'<27>', '<27>'..'<27>', '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) >= '<27>') and (frxGetSymbol(s, FPos.X) <= '<27>')) 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.
Reference in New Issue View Git Blame Copy Permalink