2398 lines
57 KiB
ObjectPascal
2398 lines
57 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastScript v1.9 }
|
|
{ Syntax memo FMX control }
|
|
{ }
|
|
{ (c) 2003-2011 by Alexander Tzyganenko, }
|
|
{ Fast Reports Inc }
|
|
{ }
|
|
{******************************************}
|
|
|
|
{ Simple syntax highlighter. Supports Pascal, C++, JS, VB and SQL syntax.
|
|
|
|
Assign text to Text property.
|
|
Assign desired value to SyntaxType property.
|
|
Call SetPos to move caret.
|
|
Call ShowMessage to display an error message at the bottom.
|
|
}
|
|
|
|
unit FMX.fs_synmemo;
|
|
|
|
interface
|
|
|
|
{$I fs.inc}
|
|
{$I fmx.inc}
|
|
|
|
uses
|
|
System.Classes, System.Variants, System.UIConsts, System.SysUtils, System.UITypes, System.Types,
|
|
FMX.Controls, FMX.Forms, FMX.Menus, FMX.Types, FMX.Edit, FMX.Platform, FMX.TreeView
|
|
{$IFDEF DELPHI18}
|
|
,FMX.StdCtrls
|
|
{$ENDIF}
|
|
{$IFDEF DELPHI19}
|
|
, FMX.Graphics
|
|
{$ENDIF}
|
|
{$IFDEF DELPHI19}
|
|
, FMX.Text
|
|
{$ENDIF}
|
|
{$IFDEF DELPHI29}
|
|
, FMX.BaseTypeAliases, FMX.FormTypeAliases
|
|
{$ENDIF};
|
|
|
|
type
|
|
TSyntaxType = (stPascal, stCpp, stJs, stVB, stSQL, stText);
|
|
TCharAttr = (caNo, caText, caBlock, caComment, caKeyword, caString);
|
|
TCharAttributes = set of TCharAttr;
|
|
|
|
type
|
|
TfsBorderSettings = class(TPersistent)
|
|
private
|
|
FFill: TBrush;
|
|
FWidth: Integer;
|
|
private
|
|
procedure SetFill(const Value: TBrush);
|
|
procedure SetWidth(const Value: Integer);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
published
|
|
property Fill: TBrush read FFill write SetFill;
|
|
property Width: Integer read FWidth write SetWidth;
|
|
end;
|
|
|
|
TfsFontSettings = class(TPersistent)
|
|
private
|
|
FFill: TBrush;
|
|
FFont: TFont;
|
|
procedure SetFill(const Value: TBrush);
|
|
procedure SetFont(const Value: TFont);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
published
|
|
property Fill: TBrush read FFill write SetFill;
|
|
property Font: TFont read FFont write SetFont;
|
|
end;
|
|
|
|
{$i frxPlatformsAttribute.inc}
|
|
TfsSyntaxMemo = class(TStyledControl{$IFDEF DELPHI18}, ICaret{$ENDIF})
|
|
private
|
|
{$IFDEF DELPHI18}
|
|
FCaret: TCaret;
|
|
{$ENDIF}
|
|
FBorder: TfsBorderSettings;
|
|
FFill: TBrush;
|
|
FFontSettings: TfsFontSettings;
|
|
FGutterFill: TBrush;
|
|
FAllowLinesChange: Boolean;
|
|
FCharHeight: Single;
|
|
FCharWidth: Single;
|
|
FDoubleClicked: Boolean;
|
|
FDown: Boolean;
|
|
FGutterWidth: Integer;
|
|
FFooterHeight: Integer;
|
|
FIsMonoType: Boolean;
|
|
FKeywords: String;
|
|
FMaxLength: Integer;
|
|
FMessage: String;
|
|
FModified: Boolean;
|
|
FMoved: Boolean;
|
|
FOffset: TPoint;
|
|
FPos: TPoint;
|
|
FReadOnly: Boolean;
|
|
FSelEnd: TPoint;
|
|
FSelStart: TPoint;
|
|
FSynStrings: TStrings;
|
|
FSyntaxType: TSyntaxType;
|
|
FTempPos: TPoint;
|
|
FText: TStringList;
|
|
FKeywordAttr: TfsFontSettings;
|
|
FStringAttr: TfsFontSettings;
|
|
FTextAttr: TfsFontSettings;
|
|
FCommentAttr: TfsFontSettings;
|
|
FBlockColor: TAlphaColor;
|
|
FBlockFontColor: TAlphaColor;
|
|
FUndo: TStringList;
|
|
FUpdating: Boolean;
|
|
FUpdatingSyntax: Boolean;
|
|
FVScroll: TScrollBar;
|
|
FWindowSize: TPoint;
|
|
FPopupMenu: TPopupMenu;
|
|
KWheel: Integer;
|
|
LastSearch: String;
|
|
FShowGutter: boolean;
|
|
FShowFooter: boolean;
|
|
Bookmarks: array of Integer;
|
|
FActiveLine: Integer;
|
|
FOnChange: TNotifyEvent;
|
|
FTmpCanvas: TBitmap;
|
|
procedure CalcCharSize;
|
|
function GetCharWidth(Str: String): Single;
|
|
function GetText: TStrings;
|
|
procedure SetText(Value: TStrings);
|
|
procedure SetSyntaxType(Value: TSyntaxType);
|
|
procedure SetShowGutter(Value: boolean);
|
|
procedure SetShowFooter(Value: boolean);
|
|
function FMemoFind(Text: String; var Position : TPoint): boolean;
|
|
function GetCharAttr(Pos: TPoint): TCharAttributes;
|
|
function GetLineBegin(Index: Integer): Integer;
|
|
function GetPlainTextPos(Pos: TPoint): Integer;
|
|
function GetPosPlainText(Pos: Integer): TPoint;
|
|
function GetSelText: String;
|
|
function LineAt(Index: Integer): String;
|
|
function LineLength(Index: Integer): Integer;
|
|
function Pad(n: Integer): String;
|
|
procedure AddSel;
|
|
procedure AddUndo;
|
|
procedure ClearSel;
|
|
procedure CreateSynArray;
|
|
procedure DoChange;
|
|
procedure EnterIndent;
|
|
procedure SetSelText(Value: String);
|
|
procedure ShiftSelected(ShiftRight: Boolean);
|
|
procedure ShowCaretPos;
|
|
procedure TabIndent;
|
|
procedure UnIndent;
|
|
procedure UpdateScrollBar;
|
|
procedure UpdateSyntax;
|
|
procedure DoLeft;
|
|
procedure DoRight;
|
|
procedure DoUp;
|
|
procedure DoDown;
|
|
procedure DoHome(Ctrl: Boolean);
|
|
procedure DoEnd(Ctrl: Boolean);
|
|
procedure DoPgUp;
|
|
procedure DoPgDn;
|
|
procedure DoChar(Ch: Char);
|
|
procedure DoReturn;
|
|
procedure DoDel;
|
|
procedure DoBackspace;
|
|
procedure DoCtrlI;
|
|
procedure DoCtrlU;
|
|
procedure DoCtrlR;
|
|
procedure DoCtrlL;
|
|
procedure ScrollClick(Sender: TObject);
|
|
procedure ScrollEnter(Sender: TObject);
|
|
procedure LinesChange(Sender: TObject);
|
|
procedure ShowPos;
|
|
procedure BookmarkDraw(Y :Single; ALine : integer);
|
|
procedure ActiveLineDraw(Y :Single; ALine : integer);
|
|
procedure CorrectBookmark(Line : integer; delta : integer);
|
|
procedure SetKeywordAttr(Value: TfsFontSettings);
|
|
procedure SetStringAttr(Value: TfsFontSettings);
|
|
procedure SetTextAttr(Value: TfsFontSettings);
|
|
procedure SetCommentAttr(Value: TfsFontSettings);
|
|
procedure SetBorder(const Value: TfsBorderSettings);
|
|
procedure SetFill(const Value: TBrush);
|
|
procedure SetFontSettings(const Value: TfsFontSettings);
|
|
procedure SetGutterFill(const Value: TBrush);
|
|
protected
|
|
procedure SetParent(const Value: TFmxObject); override;
|
|
function GetClientRect: TRectF;
|
|
procedure DblClick; override;
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
|
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
|
procedure KeyDown(var Key: Word; var KeyChar: WideChar; Shift: TShiftState); override;
|
|
procedure CopyPopup(Sender: TObject);
|
|
procedure PastePopup(Sender: TObject);
|
|
procedure CutPopup(Sender: TObject);
|
|
procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override;
|
|
procedure DOver(Sender: TObject; const Data: TDragObject; const Point: TPointF; {$IFNDEF DELPHI20}var Accept: Boolean{$ELSE} var Operation: TDragOperation{$ENDIF});
|
|
procedure DDrop(Sender: TObject; const Data: TDragObject; const Point: TPointF);
|
|
procedure DoExit; override;
|
|
procedure Resize; override;
|
|
procedure UpdateWindowSize;
|
|
procedure FontChanged(Sender: TObject);
|
|
procedure DialogKey(var Key: Word; Shift: TShiftState); override;
|
|
{$IFDEF Delphi18}
|
|
function ICaret.GetObject = GetCaret;
|
|
function GetCaret: TCustomCaret;
|
|
procedure SetCaret(const Value: TCaret);
|
|
procedure ShowCaret;
|
|
procedure HideCaret;
|
|
{$ENDIF}
|
|
{$IFDEF Delphi17}
|
|
function CreateCaret: TCaret; {$IFNDEF Delphi18} override; {$ENDIF}
|
|
{$ENDIF}
|
|
procedure SetAttr(aCanvas: TCanvas; a: TCharAttributes);
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Paint; override;
|
|
procedure CopyToClipboard;
|
|
procedure CutToClipboard;
|
|
procedure PasteFromClipboard;
|
|
procedure SetPos(x, y: Integer);
|
|
procedure ShowMessage(s: String);
|
|
procedure Undo;
|
|
procedure UpdateView;
|
|
function GetPos: TPoint;
|
|
function Find(Text: String): boolean;
|
|
property Modified: Boolean read FModified write FModified;
|
|
property SelText: String read GetSelText write SetSelText;
|
|
function IsBookmark(Line : integer): integer;
|
|
procedure AddBookmark(Line, Number : integer);
|
|
procedure DeleteBookmark(Number : integer);
|
|
procedure GotoBookmark(Number : integer);
|
|
procedure SetActiveLine(Line : Integer);
|
|
function GetActiveLine: Integer;
|
|
{$IFDEF Delphi18}
|
|
property Caret: TCaret read FCaret write SetCaret;
|
|
{$ENDIF}
|
|
published
|
|
property Align;
|
|
property Anchors;
|
|
property DragMode;
|
|
property Enabled;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property Width;
|
|
property Height;
|
|
property Visible;
|
|
{$IFDEF Delphi18}
|
|
property Cursor;
|
|
{$ENDIF}
|
|
property BlockColor: TAlphaColor read FBlockColor write FBlockColor;
|
|
property BlockFontColor: TAlphaColor read FBlockFontColor write FBlockFontColor;
|
|
property CommentAttr: TfsFontSettings read FCommentAttr write SetCommentAttr;
|
|
property KeywordAttr: TfsFontSettings read FKeywordAttr write SetKeywordAttr;
|
|
property StringAttr: TfsFontSettings read FStringAttr write SetStringAttr;
|
|
property TextAttr: TfsFontSettings read FTextAttr write SetTextAttr;
|
|
property Border: TfsBorderSettings read FBorder write SetBorder;
|
|
property Fill: TBrush read FFill write SetFill;
|
|
property FontSettings: TfsFontSettings read FFontSettings write SetFontSettings;
|
|
property GutterFill: TBrush read FGutterFill write SetGutterFill;
|
|
property Lines: TStrings read GetText write SetText;
|
|
property ReadOnly: Boolean read FReadOnly write FReadOnly;
|
|
property SyntaxType: TSyntaxType read FSyntaxType write SetSyntaxType;
|
|
property ShowFooter: boolean read FShowFooter write SetShowFooter;
|
|
property ShowGutter: boolean read FShowGutter write SetShowGutter;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property OnClick;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnKeyDown;
|
|
property OnMouseDown;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
end;
|
|
|
|
TfsSynMemoSearch = class(TForm)
|
|
Search: TButton;
|
|
Button1: TButton;
|
|
Label1: TLabel;
|
|
Edit1: TEdit;
|
|
procedure FormKeyPress(Sender: TObject; var Key: Char);
|
|
private
|
|
{ Private declarations }
|
|
public
|
|
{ Public declarations }
|
|
end;
|
|
|
|
var
|
|
SynMemoSearch: TfsSynMemoSearch;
|
|
|
|
implementation
|
|
|
|
{$R *.FMX}
|
|
{$IFDEF DELPHI18}
|
|
type THachCaret = class(TCaret);
|
|
{$ENDIF}
|
|
|
|
const
|
|
PasKeywords =
|
|
'and,array,begin,case,const,div,do,downto,else,end,except,finally,'+
|
|
'for,function,if,in,is,mod,nil,not,of,or,procedure,program,repeat,shl,'+
|
|
'shr,string,then,to,try,until,uses,var,while,with,xor';
|
|
|
|
CppKeywords =
|
|
'bool,break,case,char,continue,define,default,delete,do,double,else,'+
|
|
'except,finally,float,for,if,include,int,is,new,return,string,switch,try,'+
|
|
'variant,void,while';
|
|
|
|
SQLKeywords =
|
|
'active,after,all,alter,and,any,as,asc,ascending,at,auto,' +
|
|
'base_name,before,begin,between,by,cache,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';
|
|
|
|
JSKeywords =
|
|
'break,case,continue,default,delete,do,else,except,finally,for,function,' +
|
|
'import,in,is,if,new,return,switch,try,var,while,with';
|
|
|
|
VBKeywords =
|
|
'addressof,and,as,byref,byval,case,catch,delete,dim,do,else,elseif,' +
|
|
'end,endif,exit,finally,for,function,if,imports,is,loop,mod,new,next,' +
|
|
'not,or,rem,return,select,set,step,sub,then,to,try,wend,while,with,xor';
|
|
|
|
|
|
WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_'];
|
|
LineBreak: AnsiString = sLineBreak;
|
|
|
|
function IsUnicodeChar(Chr: Char): Boolean;
|
|
begin
|
|
Result := ((Chr >= Char($007F)) and (Chr <= Char($FFFF)));
|
|
end;
|
|
|
|
|
|
{ TfsSyntaxMemo }
|
|
|
|
constructor TfsSyntaxMemo.Create(AOwner: TComponent);
|
|
var
|
|
m: TMenuItem;
|
|
i: integer;
|
|
begin
|
|
inherited Create(AOwner);
|
|
FTmpCanvas := TBitmap.Create(1, 1);
|
|
{$IFDEF DELPHI18}
|
|
FCaret := CreateCaret;
|
|
{$ENDIF}
|
|
FVScroll := TScrollBar.Create(Self);
|
|
FVScroll.Stored := False;
|
|
FVScroll.Orientation := TOrientation.orVertical;
|
|
|
|
FFontSettings := TfsFontSettings.Create;
|
|
FFontSettings.Font.OnChanged := FontChanged;
|
|
FFontSettings.Fill.Color := TAlphaColorRec.Black;
|
|
|
|
FCommentAttr := TfsFontSettings.Create;
|
|
FCommentAttr.Fill.Color := TAlphaColorRec.Green;
|
|
FCommentAttr.Font.Style := [TFontStyle.fsItalic];
|
|
|
|
FKeywordAttr := TfsFontSettings.Create;
|
|
FKeywordAttr.FFill.Color := TAlphaColorRec.Navy;
|
|
FKeywordAttr.Font.Style := [TFontStyle.fsBold];
|
|
|
|
FStringAttr := TfsFontSettings.Create;
|
|
FStringAttr.Fill.Color := TAlphaColorRec.Navy;
|
|
FStringAttr.Font.Style := [];
|
|
|
|
FTextAttr := TfsFontSettings.Create;
|
|
FTextAttr.Fill.Color := TAlphaColorRec.Black;
|
|
FTextAttr.Font.Style := [];
|
|
|
|
FBorder := TfsBorderSettings.Create;
|
|
FFill := TBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.White);
|
|
FGutterFill := TBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.Whitesmoke);
|
|
|
|
if AOwner is TFmxObject then
|
|
Parent := AOwner as TFmxObject;
|
|
|
|
OnDragOver := DOver;
|
|
OnDragDrop := DDrop;
|
|
KWheel := -1;
|
|
|
|
|
|
FText := TStringList.Create;
|
|
FUndo := TStringList.Create;
|
|
FSynStrings := TStringList.Create;
|
|
FText.Add('');
|
|
FText.OnChange := LinesChange;
|
|
FMaxLength := 1024;
|
|
SyntaxType := stPascal;
|
|
FMoved := True;
|
|
SetPos(1, 1);
|
|
FOffset := Point(0, 0);
|
|
CanFocus := True;
|
|
Cursor := crIBeam;
|
|
|
|
FBlockColor := TAlphaColorRec.Blue;
|
|
FBlockFontColor := TAlphaColorRec.White;
|
|
|
|
FPopupMenu := TPopupMenu.Create(Self);
|
|
m := TMenuItem.Create(FPopupMenu);
|
|
m.Text := 'Cut';
|
|
m.OnClick := CutPopup;
|
|
FPopupMenu.AddObject(m);
|
|
m := TMenuItem.Create(FPopupMenu);
|
|
m.Text := 'Copy';
|
|
m.OnClick := CopyPopup;
|
|
FPopupMenu.AddObject(m);
|
|
m := TMenuItem.Create(FPopupMenu);
|
|
m.Text := 'Paste';
|
|
m.OnClick := PastePopup;
|
|
FPopupMenu.AddObject(m);
|
|
|
|
LastSearch := '';
|
|
Setlength(Bookmarks, 10);
|
|
for i := 0 to Length(Bookmarks)-1 do
|
|
Bookmarks[i] := -1;
|
|
|
|
FActiveLine := -1;
|
|
|
|
Height := 200;
|
|
Width := 200;
|
|
CalcCharSize;
|
|
end;
|
|
|
|
destructor TfsSyntaxMemo.Destroy;
|
|
begin
|
|
FPopupMenu.Free;
|
|
FCommentAttr.Free;
|
|
FKeywordAttr.Free;
|
|
FStringAttr.Free;
|
|
FFontSettings.Free;
|
|
FTextAttr.Free;
|
|
FText.Free;
|
|
FUndo.Free;
|
|
FSynStrings.Free;
|
|
//FVScroll.Free;
|
|
FFill.Free;
|
|
FBorder.Free;
|
|
FGutterFill.Free;
|
|
{$IFDEF DELPHI18}
|
|
FCaret.Free;
|
|
{$ENDIF}
|
|
FreeAndNil(FTmpCanvas);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.CalcCharSize;
|
|
var
|
|
tmpBmp: TBitmap;
|
|
r: TRectF;
|
|
begin
|
|
tmpBmp := TBitmap.Create(1, 1);
|
|
with tmpBmp.Canvas do
|
|
begin
|
|
Font.Assign(FFontSettings.Font);
|
|
Font.Style := [];
|
|
r := RectF(0, 0, 1000, 1000);
|
|
MeasureText(r, 'WWWWWW', True, [], TTextAlign.taLeading); // taLeading returns incorrect results in xe2
|
|
FCharHeight := r.Height + 2;
|
|
FCharWidth := r.Width / 6;
|
|
FIsMonoType := Pos('COURIER NEW', AnsiUppercase(FFontSettings.Font.Family)) <> 0;
|
|
end;
|
|
tmpBmp.Free;
|
|
end;
|
|
|
|
{$IFDEF Delphi17}
|
|
function TfsSyntaxMemo.CreateCaret: TCaret;
|
|
begin
|
|
Result := TCaret.Create(Self);
|
|
Result.Visible := True;
|
|
{$IFDEF DELPHI20}
|
|
Result.ReadOnly := False;
|
|
Result.Color := claBlack;
|
|
{$ENDIF}
|
|
Result.Pos := TPointF.Create(1, 1);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF DELPHI18}
|
|
function TfsSyntaxMemo.GetCaret: TCustomCaret;
|
|
begin
|
|
Result := FCaret;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetCaret(const Value: TCaret);
|
|
begin
|
|
if Assigned(FCaret) then
|
|
FCaret.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ShowCaret;
|
|
begin
|
|
THachCaret(FCaret).Show;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.HideCaret;
|
|
begin
|
|
THachCaret(FCaret).Hide;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TfsSyntaxMemo.ShowCaretPos;
|
|
var
|
|
cWidth: Single;
|
|
LineLen: Integer;
|
|
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 := Round(cWidth + FCharWidth * (FPos.X - 1 - LineLen));
|
|
{$IFNDEF Delphi18}
|
|
{$IFDEF Delphi17}
|
|
if IsFocused then
|
|
begin
|
|
CaretVisible := False;
|
|
SetCaretParams(PointF(
|
|
FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth + FBorder.Width + 1,
|
|
FCharHeight * (FPos.Y - 1 - FOffset.Y) + 1),
|
|
PointF(2, FCharHeight), claBlack);
|
|
CaretVisible := True;
|
|
end
|
|
else
|
|
CaretVisible := False;
|
|
{$ELSE}
|
|
if IsFocused then
|
|
begin
|
|
SetCaretSize(PointF(2, FCharHeight));
|
|
SetCaretPos(PointF(
|
|
FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth + FBorder.Width + 1,
|
|
FCharHeight * (FPos.Y - 1 - FOffset.Y) + 1));
|
|
ShowCaretProc;
|
|
end
|
|
else
|
|
HideCaret;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
if IsFocused then
|
|
begin
|
|
//SetCaretSize(PointF(2, FCharHeight));
|
|
FCaret.Size := PointF(2, FCharHeight);
|
|
FCaret.Pos := PointF(
|
|
cWidth + FGutterWidth + FBorder.Width + 1,
|
|
FCharHeight * (FPos.Y - 1 - FOffset.Y) + 1);
|
|
ShowCaret;
|
|
// SetCaretPos(PointF(
|
|
// FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth + FBorder.Width + 1,
|
|
// FCharHeight * (FPos.Y - 1 - FOffset.Y) + 1));
|
|
// ShowCaretProc;
|
|
end
|
|
else
|
|
HideCaret;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ShowPos;
|
|
var
|
|
cRect: TRectF;
|
|
begin
|
|
if FFooterHeight > 0 then
|
|
with Canvas do
|
|
begin
|
|
Font.Family := 'Tahoma';
|
|
Font.Style := [];
|
|
Font.Size := 11;
|
|
Fill.Color := TAlphaColorRec.Black;
|
|
cRect := GetClientRect;
|
|
FillText(RectF(cRect.Left + FGutterWidth + 2, cRect.Bottom - TextHeight('|') - 8,
|
|
FGutterWidth + 4 + FCharWidth * 10 ,
|
|
(Self.Height - TextHeight('|') - 4) + FCharHeight), IntToStr(FPos.y)
|
|
+ ' : ' + IntToStr(FPos.x) + ' ', FALSE, 1, [], TTextAlign.taLeading);
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetParent(const Value: TFmxObject);
|
|
begin
|
|
inherited SetParent(Value);
|
|
if (Parent = nil) or (csDestroying in ComponentState) then Exit;
|
|
ShowGutter := True;
|
|
ShowFooter := True;
|
|
FVScroll.Parent := Self;
|
|
FVScroll.OnChange := ScrollClick;
|
|
FVScroll.OnEnter := ScrollEnter;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetClientRect: TRectF;
|
|
begin
|
|
if FVScroll.Visible then
|
|
Result := RectF(FBorder.Width, FBorder.Width,
|
|
Width - FVScroll.Width - FBorder.Width,
|
|
Height - FBorder.Width)
|
|
else
|
|
Result := RectF(FBorder.Width, FBorder.Width,
|
|
Width - FBorder.Width, Height - FBorder.Width);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.UpdateSyntax;
|
|
begin
|
|
CreateSynArray;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.UpdateScrollBar;
|
|
begin
|
|
with FVScroll do
|
|
begin
|
|
// prevent OnScroll event
|
|
FUpdating := True;
|
|
|
|
Value := 0;
|
|
ViewportSize := 0;
|
|
|
|
Max := FText.Count;
|
|
SmallChange := 1;
|
|
if FWindowSize.Y < Max then
|
|
begin
|
|
Visible := True;
|
|
ViewportSize := FWindowSize.Y;
|
|
end
|
|
else
|
|
Visible := False;
|
|
ViewportSize := FWindowSize.Y;
|
|
Value := FOffset.Y;
|
|
|
|
FUpdating := False;
|
|
end;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetText: TStrings;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FText.Count - 1 do
|
|
FText[i] := LineAt(i);
|
|
Result := FText;
|
|
FAllowLinesChange := True;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetText(Value: TStrings);
|
|
begin
|
|
FAllowLinesChange := True;
|
|
FText.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetSyntaxType(Value: TSyntaxType);
|
|
begin
|
|
FSyntaxType := Value;
|
|
if Value = stPascal then
|
|
FKeywords := PasKeywords
|
|
else if Value = stCpp then
|
|
FKeywords := CppKeywords
|
|
else if Value = stSQL then
|
|
FKeywords := SQLKeywords
|
|
else if Value = stVB then
|
|
FKeywords := VBKeywords
|
|
else if Value = stJS then
|
|
FKeywords := JSKeywords
|
|
else
|
|
FKeywords := '';
|
|
UpdateSyntax;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetPos: TPoint;
|
|
begin
|
|
Result := FPos;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoChange;
|
|
begin
|
|
FModified := True;
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.LinesChange(Sender: TObject);
|
|
begin
|
|
if FAllowLinesChange then
|
|
begin
|
|
UpdateSyntax;
|
|
FAllowLinesChange := False;
|
|
if FText.Count = 0 then
|
|
FText.Add('');
|
|
FMoved := True;
|
|
FUndo.Clear;
|
|
FPos := Point(1, 1);
|
|
FOffset := Point(0, 0);
|
|
SetPos(FPos.X, FPos.Y);
|
|
ClearSel;
|
|
ShowCaretPos;
|
|
UpdateScrollBar;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ShowMessage(s: String);
|
|
begin
|
|
FMessage := s;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure SetClipboard(const Value: String);
|
|
{$IFDEF Delphi17}
|
|
var
|
|
ClipService: IFMXClipboardService;
|
|
begin
|
|
if TPlatformServices.Current.SupportsPlatformService(IFMXClipboardService, IInterface(ClipService)) then
|
|
ClipService.SetClipboard(Value);
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
Platform.SetClipboard(Value);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function GetClipboard: String;
|
|
{$IFDEF Delphi17}
|
|
var
|
|
ClipService: IFMXClipboardService;
|
|
begin
|
|
if TPlatformServices.Current.SupportsPlatformService(IFMXClipboardService, IInterface(ClipService)) then
|
|
Result := ClipService.GetClipboard.ToString
|
|
else
|
|
Result := '';
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
Result := VarToStr(Platform.GetClipboard);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TfsSyntaxMemo.CopyToClipboard;
|
|
begin
|
|
if FSelStart.X <> 0 then
|
|
SetClipboard(SelText);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.CutToClipboard;
|
|
begin
|
|
if not FReadOnly then
|
|
begin
|
|
if FSelStart.X <> 0 then
|
|
begin
|
|
SetClipboard(SelText);
|
|
SelText := '';
|
|
end;
|
|
CorrectBookmark(FSelStart.Y, FSelStart.Y - FSelEnd.Y);
|
|
Repaint;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.PasteFromClipboard;
|
|
begin
|
|
if (not FReadOnly) then
|
|
SelText := GetClipboard;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.LineAt(Index: Integer): String;
|
|
begin
|
|
if Index < FText.Count then
|
|
Result := TrimRight(FText[Index])
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function TfsSyntaxMemo.LineLength(Index: Integer): Integer;
|
|
begin
|
|
if Index < 0 then
|
|
Result := 0 else
|
|
Result := Length(LineAt(Index));
|
|
end;
|
|
|
|
function TfsSyntaxMemo.Pad(n: Integer): String;
|
|
begin
|
|
result := '';
|
|
SetLength(result, n);
|
|
Result := StringOfChar(Char(' '), n)
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.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);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.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));
|
|
FText.Text := Copy(s, 11, Length(s) - 10);
|
|
FUndo.Delete(FUndo.Count - 1);
|
|
SetPos(FPos.X, FPos.Y);
|
|
UpdateSyntax;
|
|
DoChange;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetPlainTextPos(Pos: TPoint): Integer;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := 0;
|
|
for i := 0 to Pos.Y - 2 do
|
|
Result := Result + Length(FText[i]) + Length(LineBreak);
|
|
Result := Result + Pos.X;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetPosPlainText(Pos: Integer): TPoint;
|
|
var
|
|
i: Integer;
|
|
s: String;
|
|
begin
|
|
Result := Point(0, 1);
|
|
s := FText.Text;
|
|
i := 1;
|
|
while i <= Pos do
|
|
if s[i] = Char(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 TfsSyntaxMemo.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 TfsSyntaxMemo.TabIndent;
|
|
begin
|
|
SelText := Pad(2);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.EnterIndent;
|
|
var
|
|
res: Integer;
|
|
begin
|
|
if Trim(FText[FPos.Y - 1]) = '' then
|
|
res := FPos.X else
|
|
res := GetLineBegin(FPos.Y - 1);
|
|
|
|
CorrectBookmark(FPos.Y, 1);
|
|
|
|
FPos := Point(1, FPos.Y + 1);
|
|
SelText := Pad(res - 1);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.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 TfsSyntaxMemo.ShiftSelected(ShiftRight: Boolean);
|
|
var
|
|
i, ib, ie: Integer;
|
|
s: String;
|
|
Shift: Integer;
|
|
begin
|
|
if FReadOnly then exit;
|
|
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
|
|
Delete(s, 1, Shift);
|
|
FText[i] := s;
|
|
end;
|
|
UpdateSyntax;
|
|
DoChange;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetSelText: String;
|
|
var
|
|
p1, p2: TPoint;
|
|
i: Integer;
|
|
begin
|
|
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 := Copy(FText.Text, i, GetPlainTextPos(p2) - i + 1);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetSelText(Value: String);
|
|
var
|
|
p1, p2, p3: TPoint;
|
|
i: Integer;
|
|
s: String;
|
|
begin
|
|
if FReadOnly then exit;
|
|
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;
|
|
|
|
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;
|
|
Delete(s, i, GetPlainTextPos(p2) - i + 1);
|
|
Insert(Value, s, i);
|
|
FText.Text := s;
|
|
p3 := GetPosPlainText(i + Length(Value));
|
|
|
|
CorrectBookmark(FPos.Y, p3.y-FPos.Y);
|
|
|
|
SetPos(p3.X, p3.Y);
|
|
FSelStart.X := 0;
|
|
DoChange;
|
|
UpdateSyntax;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ClearSel;
|
|
begin
|
|
if FSelStart.X <> 0 then
|
|
begin
|
|
FSelStart := Point(0, 0);
|
|
Repaint;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.AddSel;
|
|
begin
|
|
if FSelStart.X = 0 then
|
|
FSelStart := FTempPos;
|
|
FSelEnd := FPos;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetPos(x, y: Integer);
|
|
begin
|
|
if FMessage <> '' then
|
|
begin
|
|
FMessage := '';
|
|
Repaint;
|
|
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
|
|
FOffset.X := FOffset.X + FPos.X - (FOffset.X + FWindowSize.X);
|
|
Repaint;
|
|
end
|
|
else if FPos.X <= FOffset.X then
|
|
begin
|
|
FOffset.X := FOffset.X - (FOffset.X - FPos.X + 1);
|
|
Repaint;
|
|
end
|
|
else if FPos.Y > FOffset.Y + FWindowSize.Y then
|
|
begin
|
|
FOffset.Y := FOffset.Y + FPos.Y - (FOffset.Y + FWindowSize.Y);
|
|
Repaint;
|
|
end
|
|
else if FPos.Y <= FOffset.Y then
|
|
begin
|
|
FOffset.Y := FOffset.Y - (FOffset.Y - FPos.Y + 1);
|
|
Repaint;
|
|
end;
|
|
|
|
ShowCaretPos;
|
|
UpdateScrollBar;
|
|
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ScrollClick(Sender: TObject);
|
|
begin
|
|
if FUpdating then exit;
|
|
FOffset.Y := Round(FVScroll.Value);
|
|
if FOffset.Y > FText.Count then
|
|
FOffset.Y := FText.Count;
|
|
ShowCaretPos;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ScrollEnter(Sender: TObject);
|
|
begin
|
|
SetFocus;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DblClick;
|
|
var
|
|
s: String;
|
|
begin
|
|
FDoubleClicked := True;
|
|
DoCtrlL;
|
|
FSelStart := FPos;
|
|
s := LineAt(FPos.Y - 1);
|
|
if s <> '' then
|
|
while CharInSet(s[FPos.X],WordChars)
|
|
or IsUnicodeChar(s[FPos.X]) do
|
|
Inc(FPos.X);
|
|
FSelEnd := FPos;
|
|
Repaint;
|
|
end;
|
|
|
|
function GetComponentForm(Comp: TFmxObject): TCommonCustomForm;
|
|
begin
|
|
Result := nil;
|
|
while (Comp.Parent <> nil) do
|
|
begin
|
|
if (Comp.Parent is TCommonCustomForm) then
|
|
begin
|
|
Result := Comp.Parent as TCommonCustomForm;
|
|
Exit;
|
|
end;
|
|
Comp := Comp.Parent;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
|
var
|
|
pt: TPointF;
|
|
f: TCommonCustomForm;
|
|
r: TRectF;
|
|
LStr, s: String;
|
|
i, cIndex: Integer;
|
|
|
|
begin
|
|
if FDoubleClicked then
|
|
begin
|
|
FDoubleClicked := False;
|
|
Exit;
|
|
end;
|
|
if Button = TMouseButton.mbRight then
|
|
begin
|
|
if PopupMenu = nil then
|
|
begin
|
|
f := GetComponentForm(Self);
|
|
if f <> nil then
|
|
begin
|
|
pt := f.ClientToScreen(PointF(AbsoluteRect.Left + X, AbsoluteRect.Top + Y));
|
|
FPopUpMenu.Popup(pt.X, pt.Y);
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
FMoved := True;
|
|
if not IsFocused then
|
|
SetFocus;
|
|
FDown := True;
|
|
if FIsMonoType then
|
|
SetPos(Round((X - FGutterWidth) / FCharWidth) + 1 + FOffset.X,
|
|
Trunc(Y / FCharHeight) + 1 + FOffset.Y)
|
|
else
|
|
begin
|
|
cIndex := 0;
|
|
LStr := LineAt(FPos.Y - 1);
|
|
LStr := Copy(LineAt(FPos.Y - 1), FOffset.X + 1, Length(LStr) - (FOffset.X + 1));
|
|
for i := 1 to Length(LStr) do
|
|
begin
|
|
s := Copy(LStr, 1, i);
|
|
r := RectF(0, 0, 100000, 100000);
|
|
FTmpCanvas.Canvas.MeasureText(r, s, False, [], TTextAlign.taLeading);
|
|
if r.Width >= X - FGutterWidth then
|
|
begin
|
|
cIndex := i;
|
|
break;
|
|
end;
|
|
end;
|
|
SetPos(cIndex + 1 + FOffset.X,
|
|
Trunc(Y / FCharHeight) + 1 + FOffset.Y)
|
|
end;
|
|
ClearSel;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.MouseMove(Shift: TShiftState; X, Y: Single);
|
|
begin
|
|
if FDown then
|
|
begin
|
|
FTempPos := FPos;
|
|
FPos.X := Round((X - FGutterWidth) / FCharWidth) + 1 + FOffset.X;
|
|
FPos.Y := Round(Y / FCharHeight) + 1 + FOffset.Y;
|
|
if (FPos.X <> FTempPos.X) or (FPos.Y <> FTempPos.Y) then
|
|
begin
|
|
SetPos(FPos.X, FPos.Y);
|
|
AddSel;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Single);
|
|
begin
|
|
FDown := False;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.MouseWheel(Shift: TShiftState; WheelDelta: Integer;
|
|
var Handled: Boolean);
|
|
begin
|
|
inherited;
|
|
FVScroll.Value := FVScroll.Value + (WheelDelta div ABS(WheelDelta)) * KWheel;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DialogKey(var Key: Word; Shift: TShiftState);
|
|
begin
|
|
inherited;
|
|
if Key = 9 then
|
|
begin
|
|
if Shift = [] then
|
|
begin
|
|
if FSelStart.X <> 0 then
|
|
DoCtrlI
|
|
else
|
|
TabIndent;
|
|
end
|
|
else if Shift = [ssShift] then
|
|
DoCtrlU;
|
|
FMoved := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.KeyDown(var Key: Word; var KeyChar: WideChar; Shift: TShiftState);
|
|
var
|
|
MyKey: Boolean;
|
|
begin
|
|
inherited;
|
|
FAllowLinesChange := False;
|
|
|
|
FTempPos := FPos;
|
|
MyKey := True;
|
|
case Key of
|
|
vkLeft:
|
|
if ssCtrl in Shift then
|
|
DoCtrlL else
|
|
DoLeft;
|
|
|
|
vkRight:
|
|
if ssCtrl in Shift then
|
|
DoCtrlR else
|
|
DoRight;
|
|
|
|
vkUp:
|
|
DoUp;
|
|
|
|
vkDown:
|
|
DoDown;
|
|
|
|
vkHome:
|
|
DoHome(ssCtrl in Shift);
|
|
|
|
vkEnd:
|
|
DoEnd(ssCtrl in Shift);
|
|
|
|
vkPrior:
|
|
DoPgUp;
|
|
|
|
vkNext:
|
|
DoPgDn;
|
|
|
|
vkReturn:
|
|
if Shift = [] then
|
|
DoReturn;
|
|
|
|
vkDelete:
|
|
if ssShift in Shift then
|
|
CutToClipboard else
|
|
DoDel;
|
|
|
|
vkBack:
|
|
DoBackspace;
|
|
|
|
vkInsert:
|
|
if ssCtrl in Shift then
|
|
CopyToClipboard
|
|
else if ssShift in Shift then
|
|
PasteFromClipboard;
|
|
|
|
vkF3:
|
|
Find(LastSearch); // F3 Repeat search
|
|
|
|
else
|
|
MyKey := False;
|
|
end;
|
|
|
|
if (Shift = [ssCtrl]) or (Shift = [ssCommand]) then
|
|
begin
|
|
MyKey := True;
|
|
if (Key = Ord('c')) or (Key = Ord('C')) then // Ctrl+C Copy
|
|
CopyToClipboard
|
|
else if (Key = Ord('v')) or (Key = Ord('V')) then // Ctrl+V Paste
|
|
PasteFromClipboard
|
|
else if (Key = Ord('x')) or (Key = Ord('X')) then // Ctrl+X Cut
|
|
CutToClipboard
|
|
else if (Key = Ord('z')) or (Key = Ord('Z')) then // Ctrl+Z Undo
|
|
Undo
|
|
else if (Key = Ord('a')) or (Key = Ord('A')) then // Ctrl+A Select all
|
|
begin
|
|
SetPos(0, 0);
|
|
FSelStart := FPos;
|
|
SetPos(LineLength(FText.Count - 1) + 1, FText.Count);
|
|
FSelEnd := FPos;
|
|
Repaint;
|
|
end
|
|
else if (Key = Ord('f')) or (Key = Ord('F')) then // Ctrl+F Search
|
|
begin
|
|
SynMemoSearch := TfsSynMemoSearch.Create(nil);
|
|
if SynMemoSearch.ShowModal = mrOk then
|
|
Find(SynMemoSearch.Edit1.Text);
|
|
LastSearch := SynMemoSearch.Edit1.Text;
|
|
SynMemoSearch.Free;
|
|
end
|
|
else if (Key = Ord('y')) or (Key = Ord('Y')) 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);
|
|
UpdateSyntax;
|
|
end
|
|
else
|
|
if FText.Count = FPos.Y then
|
|
begin
|
|
FMoved := True;
|
|
AddUndo;
|
|
FText[FPos.Y - 1] := '';
|
|
FPos.X := 1;
|
|
SetPos(FPos.X, FPos.Y);
|
|
UpdateSyntax;
|
|
end
|
|
end
|
|
else if Key in [48..57] then
|
|
GotoBookmark(Key-48)
|
|
else
|
|
MyKey := False;
|
|
end;
|
|
|
|
if Shift = [ssCtrl, ssShift] then
|
|
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);
|
|
|
|
|
|
if Key in [vkLeft, vkRight, vkUp, vkDown, vkHome, vkEnd, vkPrior, vkNext] then
|
|
begin
|
|
FMoved := True;
|
|
if ssShift in Shift then
|
|
AddSel else
|
|
ClearSel;
|
|
end
|
|
else if Key in [vkReturn, vkDelete, vkBack, vkInsert] then
|
|
FMoved := True;
|
|
|
|
case WideChar(KeyChar) of
|
|
#0032..#$FFFF:
|
|
if (Shift = []) or (Shift = [ssShift]) then
|
|
begin
|
|
DoChar(WideChar(KeyChar));
|
|
FMoved := True;
|
|
end;
|
|
else
|
|
MyKey := False;
|
|
end;
|
|
if MyKey then
|
|
Key := 0;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoLeft;
|
|
begin
|
|
Dec(FPos.X);
|
|
if FPos.X < 1 then
|
|
FPos.X := 1;
|
|
SetPos(FPos.X, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoRight;
|
|
begin
|
|
Inc(FPos.X);
|
|
if FPos.X > FMaxLength then
|
|
FPos.X := FMaxLength;
|
|
SetPos(FPos.X, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoUp;
|
|
begin
|
|
Dec(FPos.Y);
|
|
if FPos.Y < 1 then
|
|
FPos.Y := 1;
|
|
SetPos(FPos.X, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoDown;
|
|
begin
|
|
Inc(FPos.Y);
|
|
if FPos.Y > FText.Count then
|
|
FPos.Y := FText.Count;
|
|
SetPos(FPos.X, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoHome(Ctrl: Boolean);
|
|
begin
|
|
if Ctrl then
|
|
SetPos(1, 1) else
|
|
SetPos(1, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.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 TfsSyntaxMemo.DoExit;
|
|
begin
|
|
{$IFDEF Delphi17}
|
|
inherited;
|
|
{$IFNDEF DELPHI18}
|
|
CaretVisible := False;
|
|
{$ELSE}
|
|
HideCaret;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
Platform.HideVirtualKeyboard;
|
|
inherited;
|
|
HideCaret;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoPgUp;
|
|
begin
|
|
if FOffset.Y > FWindowSize.Y then
|
|
begin
|
|
FOffset.Y := FOffset.Y - (FWindowSize.Y - 1);
|
|
FPos.Y := FPos.Y - (FWindowSize.Y - 1);
|
|
end
|
|
else
|
|
begin
|
|
if FOffset.Y > 0 then
|
|
begin
|
|
FPos.Y := FPos.Y - FOffset.Y;
|
|
FOffset.Y := 0;
|
|
end
|
|
else
|
|
FPos.Y := 1;
|
|
end;
|
|
SetPos(FPos.X, FPos.Y);
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoPgDn;
|
|
begin
|
|
if FOffset.Y + FWindowSize.Y < FText.Count then
|
|
begin
|
|
FOffset.Y := FOffset.Y + (FWindowSize.Y - 1);
|
|
FPos.Y := FPos.Y + (FWindowSize.Y - 1);
|
|
end
|
|
else
|
|
begin
|
|
FOffset.Y := FText.Count;
|
|
FPos.Y := FText.Count;
|
|
end;
|
|
SetPos(FPos.X, FPos.Y);
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoReturn;
|
|
var
|
|
s: String;
|
|
begin
|
|
if FReadOnly then exit;
|
|
s := LineAt(FPos.Y - 1);
|
|
FText[FPos.Y - 1] := Copy(s, 1, FPos.X - 1);
|
|
FText.Insert(FPos.Y, Copy(s, FPos.X, FMaxLength));
|
|
EnterIndent;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoDel;
|
|
var
|
|
s: String;
|
|
begin
|
|
if FReadOnly then exit;
|
|
FMessage := '';
|
|
if FSelStart.X <> 0 then
|
|
SelText := ''
|
|
else
|
|
begin
|
|
s := FText[FPos.Y - 1];
|
|
AddUndo;
|
|
if FPos.X <= LineLength(FPos.Y - 1) then
|
|
begin
|
|
Delete(s, FPos.X, 1);
|
|
FText[FPos.Y - 1] := s;
|
|
end
|
|
else if FPos.Y < FText.Count then
|
|
begin
|
|
s := s + Pad(FPos.X - Length(s) - 1) + LineAt(FPos.Y);
|
|
FText[FPos.Y - 1] := s;
|
|
FText.Delete(FPos.Y);
|
|
CorrectBookmark(FSelStart.Y, -1);
|
|
end;
|
|
UpdateScrollBar;
|
|
UpdateSyntax;
|
|
DoChange;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoBackspace;
|
|
var
|
|
s: String;
|
|
begin
|
|
if FReadOnly then exit;
|
|
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
|
|
Delete(s, FPos.X - 1, 1);
|
|
FText[FPos.Y - 1] := s;
|
|
DoLeft;
|
|
end
|
|
else
|
|
DoHome(False);
|
|
UpdateSyntax;
|
|
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);
|
|
UpdateSyntax;
|
|
DoChange;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoCtrlI;
|
|
begin
|
|
if FSelStart.X <> 0 then
|
|
ShiftSelected(True);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoCtrlU;
|
|
begin
|
|
if FSelStart.X <> 0 then
|
|
ShiftSelected(False);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoCtrlL;
|
|
var
|
|
i: Integer;
|
|
s: String;
|
|
begin
|
|
s := FText.Text;
|
|
i := Length(LineAt(FPos.Y - 1));
|
|
if FPos.X > i then
|
|
FPos.X := i;
|
|
|
|
i := GetPlainTextPos(FPos);
|
|
|
|
Dec(i);
|
|
while (i > 0) and not (CharInSet(s[i], WordChars) or IsUnicodeChar(s[i])) do
|
|
if s[i] = Char(LineBreak[1]) then
|
|
break else
|
|
Dec(i);
|
|
while (i > 0) and (CharInSet(s[i], WordChars) or IsUnicodeChar(s[i])) do
|
|
Dec(i);
|
|
Inc(i);
|
|
|
|
FPos := GetPosPlainText(i);
|
|
SetPos(FPos.X, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.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 := 0;
|
|
end;
|
|
|
|
i := GetPlainTextPos(FPos);
|
|
while (i < Length(s)) and ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do
|
|
Inc(i);
|
|
while (i < Length(s)) and not ((CharInSet(s[i], WordChars)) or IsUnicodeChar(s[i])) do
|
|
if s[i] = Char(LineBreak[1]) then
|
|
break else
|
|
Inc(i);
|
|
FPos := GetPosPlainText(i);
|
|
SetPos(FPos.X, FPos.Y);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DoChar(Ch: Char);
|
|
begin
|
|
SelText := Ch;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetCharAttr(Pos: TPoint): TCharAttributes;
|
|
|
|
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: TCharAttr;
|
|
var
|
|
s: String;
|
|
begin
|
|
if Pos.Y - 1 < FSynStrings.Count then
|
|
begin
|
|
s := FSynStrings[Pos.Y - 1];
|
|
if Pos.X <= Length(s) then
|
|
Result := TCharAttr(Ord(s[Pos.X])) else
|
|
Result := caText;
|
|
end
|
|
else
|
|
Result := caText;
|
|
end;
|
|
|
|
begin
|
|
Result := [CharAttr];
|
|
if IsBlock then
|
|
Result := Result + [caBlock];
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetCharWidth(Str: String): Single;
|
|
var
|
|
r: TRectF;
|
|
dx: Single;
|
|
j, j1: Integer;
|
|
a, a1: TCharAttributes;
|
|
|
|
function CalcSize(LStr: String): Single;
|
|
begin
|
|
if FIsMonoType then
|
|
begin
|
|
Result := FCharWidth * Length(LStr);
|
|
Exit;
|
|
end;
|
|
if LStr = '' then
|
|
begin
|
|
Result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
r := RectF(0, 0, 100000, 100000);
|
|
{ MeasureText trunc all spaces at the end, so we are using this hack to calcl size with spaces }
|
|
FTmpCanvas.Canvas.MeasureText(r, LStr + 'W', False, [], TTextAlign.taLeading);
|
|
dx := r.Width;
|
|
FTmpCanvas.Canvas.MeasureText(r, 'W', False, [], TTextAlign.taLeading);
|
|
Result := dx - r.Width;
|
|
end;
|
|
begin
|
|
|
|
j1 := 1;
|
|
a := GetCharAttr(Point(1, FPos.Y));
|
|
a1 := a;
|
|
Result := 0;
|
|
|
|
for j := 1 to Length(Str) do
|
|
begin
|
|
a1 := GetCharAttr(Point(j, FPos.Y));
|
|
if a1 <> a then
|
|
begin
|
|
SetAttr(FTmpCanvas.Canvas, a);
|
|
Result := Result + CalcSize(Copy(Str, j1, (j - j1)));
|
|
a := a1;
|
|
j1 := j;
|
|
end;
|
|
end;
|
|
SetAttr(FTmpCanvas.Canvas, a);
|
|
Result := Result + CalcSize(Copy(Str, j1, Length(Str) - (j1 - 1)));
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.Paint;
|
|
var
|
|
i, j, j1: Integer;
|
|
a, a1: TCharAttributes;
|
|
s: String;
|
|
x, y: Single;
|
|
aClientR: TRectF;
|
|
aSelColor, aSelFontColor: TAlphaColor;
|
|
|
|
procedure SetAttrL(a: TCharAttributes);
|
|
begin
|
|
SetAttr(Canvas, a);
|
|
aSelColor := FFill.Color;
|
|
aSelFontColor := Canvas.Fill.Color;
|
|
if caBlock in a then
|
|
begin
|
|
aSelColor := FBlockColor;
|
|
aSelFontColor := FBlockFontColor;
|
|
end;
|
|
|
|
// make non-selected text looking good
|
|
if aSelColor = FFill.Color then
|
|
aSelColor := 0;
|
|
end;
|
|
|
|
function MyTextOut(x, y: Single; const s: String): Single;
|
|
var
|
|
i: Integer;
|
|
dx, dy: Single;
|
|
r: TRectF;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
r := RectF(0, 0, 100000, 100000);
|
|
{ MeasureText trunc all spaces at the end, so we are using this hack to calcl size with spaces }
|
|
Canvas.MeasureText(r, s + 'W',False, [], TTextAlign.taLeading);
|
|
dx := r.Width + x;
|
|
Canvas.MeasureText(r, 'W', False, [], TTextAlign.taLeading);
|
|
dx := dx - r.Width;
|
|
if dx > (aClientR.Right - aClientR.Left) then
|
|
dx := aClientR.Right - aClientR.Left;
|
|
dy := y + FCharHeight;
|
|
if FIsMonoType then
|
|
dx := x + FCharWidth * Length(s);
|
|
Fill.Color := aSelColor;
|
|
FillRect(RectF(x + 1, y, dx + 1, dy + 1), 0, 0, AllCorners, 1);
|
|
Fill.Color := aSelFontColor;
|
|
if FIsMonoType then
|
|
FillText(RectF(x, y, dx + 1, 10000),
|
|
s, False, 1, [], TTextAlign.taLeading, TTextAlign.taLeading)
|
|
else
|
|
begin
|
|
for i := 1 to Length(s) do
|
|
FillText(RectF(x + (i - 1) * FCharWidth, y,
|
|
(x + (i - 1) * FCharWidth) + FCharWidth, y + FCharHeight),
|
|
s[i], False, 1, FillTextFlags, TTextAlign.taLeading, TTextAlign.taLeading);
|
|
end;
|
|
end;
|
|
Result := dx;
|
|
end;
|
|
|
|
begin
|
|
aClientR := GetClientRect;
|
|
with Canvas do
|
|
begin
|
|
Fill.Assign(FBorder.Fill);
|
|
FillRect(RectF(0, 0, Self.Width , Self.Height), 0, 0, AllCorners, 1, TCornerType.ctBevel);
|
|
Fill.Assign(FFill);
|
|
FillRect(aClientR, 0, 0, AllCorners, 1, TCornerType.ctBevel);
|
|
Fill.Assign(FGutterFill);
|
|
FillRect(RectF(FGutterWidth - aClientR.Left,
|
|
Self.Height - FFooterHeight - aClientR.Top,
|
|
aClientR.Left, aClientR.Top), 0, 0, AllCorners, 1, TCornerType.ctBevel);
|
|
FillRect(RectF(aClientR.Left, Self.Height - FFooterHeight - aClientR.Top,
|
|
Self.Width - aClientR.Left, Self.Height - aClientR.Top), 1, 1,
|
|
AllCorners, 1, TCornerType.ctBevel);
|
|
|
|
Stroke.Assign(FBorder.Fill);
|
|
{$IFDEF DELPHI25}
|
|
Stroke.Cap := TStrokeCap.scRound;
|
|
Stroke.Thickness := FBorder.Width;
|
|
{$ELSE}
|
|
StrokeCap := TStrokeCap.scRound;
|
|
StrokeThickness := FBorder.Width;
|
|
{$ENDIF}
|
|
x := FGutterWidth - FBorder.Width;
|
|
DrawLine(PointF(x, aClientR.Top + 1), PointF(x, aClientR.Bottom - FFooterHeight ), 1);
|
|
if FFooterHeight > 0 then
|
|
DrawLine(PointF(x, aClientR.Bottom - FFooterHeight),
|
|
PointF(aClientR.Right - 1, aClientR.Bottom - FFooterHeight), 1);
|
|
if FUpdatingSyntax then Exit;
|
|
|
|
for i := FOffset.Y to FOffset.Y + FWindowSize.Y - 1 do
|
|
begin
|
|
if i >= FText.Count then break;
|
|
|
|
s := FText[i];
|
|
j1 := FOffset.X + 1;
|
|
a := GetCharAttr(Point(j1, i + 1));
|
|
a1 := a;
|
|
x := FGutterWidth + FBorder.Width;
|
|
y := aClientR.Top + (i - FOffset.Y) * FCharHeight;
|
|
for j := j1 to FOffset.X + FWindowSize.X do
|
|
begin
|
|
if j > Length(s) then break;
|
|
|
|
a1 := GetCharAttr(Point(j, i + 1));
|
|
if a1 <> a then
|
|
begin
|
|
SetAttrL(a);
|
|
x := MyTextOut(x, y, Copy(FText[i], j1, j - j1));
|
|
a := a1;
|
|
j1 := j;
|
|
end;
|
|
end;
|
|
|
|
SetAttrL(a);
|
|
|
|
MyTextOut(x, y, Copy(s, j1, FMaxLength));
|
|
|
|
BookmarkDraw(y, i);
|
|
ActiveLineDraw(y, i);
|
|
end;
|
|
|
|
if FMessage <> '' then
|
|
begin
|
|
Font.Family := 'Tahoma';
|
|
Font.Style := [TFontStyle.fsBold];
|
|
Font.Size := 8;
|
|
Fill.Color := TAlphaColorRec.Maroon;
|
|
FillRect(RectF(aClientR.Left, aClientR.Bottom - TextHeight('|') - 6, aClientR.Right , aClientR.Bottom), 0, 0,
|
|
AllCorners, 1, TCornerType.ctBevel);
|
|
Fill.Color := TAlphaColorRec.White;
|
|
FillText(RectF(aClientR.Left + 6, aClientR.Bottom - TextHeight('|') - 5,
|
|
6 + TextWidth('W') * Length(FMessage), aClientR.Bottom), FMessage,
|
|
False, 1, [], TTextAlign.taLeading)
|
|
end
|
|
else
|
|
ShowPos;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.CreateSynArray;
|
|
var
|
|
i, n, Pos: Integer;
|
|
ch: Char;
|
|
FSyn: String;
|
|
|
|
procedure SkipSpaces;
|
|
begin
|
|
while (Pos <= Length(FSyn)) and
|
|
((CharInSet(FSyn[Pos], [#1..#32])) or
|
|
not (CharInSet(FSyn[Pos],['_', 'A'..'Z', 'a'..'z', '''', '"', '/', '{', '(', '-']))) do
|
|
Inc(Pos);
|
|
end;
|
|
|
|
function IsKeyWord(const s: String): Boolean;
|
|
begin
|
|
Result := False;
|
|
if FKeywords = '' then exit;
|
|
|
|
if FKeywords[1] <> ',' then
|
|
FKeywords := ',' + FKeywords;
|
|
if FKeywords[Length(FKeywords)] <> ',' then
|
|
FKeywords := FKeywords + ',';
|
|
|
|
Result := System.Pos(',' + AnsiLowerCase(s) + ',', FKeywords) <> 0;
|
|
end;
|
|
|
|
function GetIdent: TCharAttr;
|
|
var
|
|
i: Integer;
|
|
cm1, cm2, cm3, cm4, st1: Char;
|
|
begin
|
|
i := Pos;
|
|
Result := caText;
|
|
|
|
if FSyntaxType = stPascal then
|
|
begin
|
|
cm1 := '/';
|
|
cm2 := '{';
|
|
cm3 := '(';
|
|
cm4 := ')';
|
|
st1 := '''';
|
|
end
|
|
else if FSyntaxType in [stCpp,stJs,stVb] then
|
|
begin
|
|
cm1 := '/';
|
|
cm2 := ' ';
|
|
cm3 := '/';
|
|
cm4 := '/';
|
|
st1 := '"';
|
|
end
|
|
else if FSyntaxType = stSQL then
|
|
begin
|
|
cm1 := '-';
|
|
cm2 := ' ';
|
|
cm3 := '/';
|
|
cm4 := '/';
|
|
st1 := '"';
|
|
end
|
|
else
|
|
begin
|
|
cm1 := ' ';
|
|
cm2 := ' ';
|
|
cm3 := ' ';
|
|
cm4 := ' ';
|
|
st1 := ' ';
|
|
end;
|
|
|
|
if CharInSet(FSyn[Pos], ['_', 'A'..'Z', 'a'..'z']) then
|
|
begin
|
|
while CharInSet(FSyn[Pos], ['_', 'A'..'Z', 'a'..'z', '0'..'9']) do
|
|
Inc(Pos);
|
|
if IsKeyWord(Copy(FSyn, i, Pos - i)) then
|
|
Result := caKeyword;
|
|
Dec(Pos);
|
|
end
|
|
else if (FSyn[Pos] = cm1) and (FSyn[Pos + 1] = cm1) then
|
|
begin
|
|
while (Pos <= Length(FSyn)) and not (CharInSet(FSyn[Pos], [#10, #13])) do
|
|
Inc(Pos);
|
|
Result := caComment;
|
|
end
|
|
else if FSyn[Pos] = cm2 then
|
|
begin
|
|
while (Pos <= Length(FSyn)) and (FSyn[Pos] <> '}') do
|
|
Inc(Pos);
|
|
Result := caComment;
|
|
end
|
|
else if (FSyn[Pos] = cm3) and (FSyn[Pos + 1] = '*') then
|
|
begin
|
|
while (Pos < Length(FSyn)) and not ((FSyn[Pos] = '*') and (FSyn[Pos + 1] = cm4)) do
|
|
Inc(Pos);
|
|
Inc(Pos, 2);
|
|
Result := caComment;
|
|
end
|
|
else if FSyn[Pos] = st1 then
|
|
begin
|
|
Inc(Pos);
|
|
while (Pos < Length(FSyn)) and (FSyn[Pos] <> st1) and not (CharInSet(FSyn[Pos], [#10, #13])) do
|
|
Inc(Pos);
|
|
Result := caString;
|
|
end;
|
|
Inc(Pos);
|
|
end;
|
|
|
|
begin
|
|
FSyn := FText.Text + #0#0#0#0#0#0#0#0#0#0#0;
|
|
FAllowLinesChange := False;
|
|
Pos := 1;
|
|
|
|
while Pos < Length(FSyn) do
|
|
begin
|
|
n := Pos;
|
|
SkipSpaces;
|
|
for i := n to Pos - 1 do
|
|
if FSyn[i] > #31 then
|
|
FSyn[i] := Chr(Ord(caText));
|
|
|
|
n := Pos;
|
|
ch := Chr(Ord(GetIdent));
|
|
for i := n to Pos - 1 do
|
|
if i <= Length(FSyn) then
|
|
if FSyn[i] > #31 then
|
|
FSyn[i] := ch;
|
|
end;
|
|
|
|
FUpdatingSyntax := True;
|
|
FSynStrings.Text := FSyn;
|
|
FSynStrings.Add(' ');
|
|
FUpdatingSyntax := False;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.UpdateView;
|
|
begin
|
|
UpdateSyntax;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.UpdateWindowSize;
|
|
begin
|
|
if FCharWidth = 0 then exit;
|
|
FWindowSize := Point(Trunc((Width - FGutterWidth - FBorder.Width * 2) / FCharWidth),
|
|
Trunc((Height - FFooterHeight - FBorder.Width * 2) / FCharHeight));
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.CopyPopup(Sender: TObject);
|
|
begin
|
|
CopyToClipboard;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.PastePopup(Sender: TObject);
|
|
begin
|
|
PasteFromClipboard;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.Resize;
|
|
begin
|
|
inherited;
|
|
UpdateWindowSize;
|
|
FVScroll.Position.Y := FBorder.Width;
|
|
FVScroll.Height := Height - FFooterHeight - FBorder.Width;
|
|
FVScroll.Width := 16;
|
|
FVScroll.Position.X := Width - FVScroll.Width - FBorder.Width;
|
|
UpdateScrollBar;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.CutPopup(Sender: TObject);
|
|
begin
|
|
CutToClipboard;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetShowGutter(Value: boolean);
|
|
begin
|
|
FShowGutter := Value;
|
|
if Value then
|
|
FGutterWidth := 20
|
|
else
|
|
FGutterWidth := 0;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetShowFooter(Value: boolean);
|
|
begin
|
|
FShowFooter := Value;
|
|
if Value then
|
|
FFooterHeight := 20
|
|
else
|
|
FFooterHeight := 0;
|
|
Repaint;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.FMemoFind(Text: String; var Position : TPoint): boolean;
|
|
var
|
|
i, j : integer;
|
|
begin
|
|
j := 0;
|
|
result := False;
|
|
if FText.Count > 1 then
|
|
begin
|
|
Text := UpperCase(Text);
|
|
for i := Position.Y to FText.Count - 1 do
|
|
begin
|
|
j := Pos( Text, UpperCase(FText[i]));
|
|
if j > 0 then
|
|
begin
|
|
Result := True;
|
|
break;
|
|
end
|
|
end;
|
|
Position.X := j;
|
|
Position.Y := i + 1;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.FontChanged(Sender: TObject);
|
|
begin
|
|
FCommentAttr.Font.Size := FFontSettings.Font.Size;
|
|
FCommentAttr.Font.Family := FFontSettings.Font.Family;
|
|
FKeywordAttr.Font.Size := FFontSettings.Font.Size;
|
|
FKeywordAttr.Font.Family := FFontSettings.Font.Family;
|
|
FStringAttr.Font.Size := FFontSettings.Font.Size;
|
|
FStringAttr.Font.Family := FFontSettings.Font.Family;
|
|
FTextAttr.Font.Size := FFontSettings.Font.Size;
|
|
FTextAttr.Font.Family := FFontSettings.Font.Family;
|
|
CalcCharSize;
|
|
{ need to uptade size, maybe font size was changed }
|
|
UpdateWindowSize;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.Find(Text: String): boolean;
|
|
var
|
|
Position: TPoint;
|
|
begin
|
|
Position := FPos;
|
|
if FMemoFind(Text, Position) then
|
|
begin
|
|
SetPos(Position.X, Position.Y);
|
|
result := true;
|
|
end
|
|
else
|
|
begin
|
|
ShowMessage('Text "'+Text+'" not found.');
|
|
result := false;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.ActiveLineDraw(Y : Single; ALine : integer);
|
|
begin
|
|
if ShowGutter then
|
|
with Canvas do
|
|
if ALine = FActiveLine then
|
|
begin
|
|
Fill.Color := TAlphaColorRec.Red;
|
|
//Pen.Color := clBlack;
|
|
FillEllipse(RectF(4, Y + 4, 11, Y + 15), 1);
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.BookmarkDraw(Y : Single; ALine : integer);
|
|
var
|
|
bm : integer;
|
|
begin
|
|
if ShowGutter then
|
|
with Canvas do
|
|
begin
|
|
bm := IsBookmark(ALine);
|
|
if bm >= 0 then
|
|
begin
|
|
Fill.Color := TAlphaColorRec.Black;
|
|
FillRect(RectF(3 + Border.Width, Y + 1, 13 + Border.Width, Y + 12), 0, 0,
|
|
AllCorners, 1, TCornerType.ctBevel);
|
|
Fill.Color := TAlphaColorRec.Green;
|
|
FillRect(RectF(2 + Border.Width, Y + 2, 12 + Border.Width, Y + 13), 0, 0,
|
|
AllCorners, 1, TCornerType.ctBevel);
|
|
Font.Family := 'Tahoma';
|
|
Fill.Color := TAlphaColorRec.White;
|
|
Font.Style := [TFontStyle.fsBold];
|
|
Font.Size := 7;
|
|
y := y + 2.0;
|
|
FillText(RectF(4 + Border.Width, Y, 4 + TextWidth('7') + Border.Width,
|
|
Y + TextHeight('7')), IntToStr(bm), False, 1, [], TTextAlign.taLeading)
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.IsBookmark(Line : integer): integer;
|
|
var
|
|
Pos : integer;
|
|
begin
|
|
Result := -1;
|
|
for Pos := 0 to Length(Bookmarks) - 1 do
|
|
if Bookmarks[Pos] = Line then
|
|
begin
|
|
Result := Pos;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.AddBookmark(Line, Number : integer);
|
|
begin
|
|
if Number < Length(Bookmarks) then
|
|
begin
|
|
Bookmarks[Number] := Line;
|
|
Repaint;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DeleteBookmark(Number : integer);
|
|
begin
|
|
if Number < Length(Bookmarks) then
|
|
begin
|
|
Bookmarks[Number] := -1;
|
|
Repaint;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.CorrectBookmark(Line : integer; delta : integer);
|
|
var
|
|
i : integer;
|
|
begin
|
|
for i := 0 to Length(Bookmarks) - 1 do
|
|
if Bookmarks[i] >= Line then
|
|
Inc(Bookmarks[i], Delta);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.GotoBookmark(Number : integer);
|
|
begin
|
|
if Number < Length(Bookmarks) then
|
|
if Bookmarks[Number] >= 0 then
|
|
SetPos(0, Bookmarks[Number] + 1);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DOver(Sender: TObject; const Data: TDragObject; const Point: TPointF; {$IFNDEF DELPHI20}var Accept: Boolean{$ELSE} var Operation: TDragOperation{$ENDIF});
|
|
begin
|
|
{$IFNDEF DELPHI20}
|
|
Accept := Data.Source is TTreeView;
|
|
{$ELSE}
|
|
if Data.Source is TTreeView then
|
|
Operation := TDragOperation.Copy;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.DDrop(Sender: TObject; const Data: TDragObject; const Point: TPointF);
|
|
begin
|
|
if Data.Source is TTreeView then
|
|
begin
|
|
SetPos(Round((Point.X - FGutterWidth) / FCharWidth) + 1 + FOffset.X,
|
|
Round(Point.Y / FCharHeight) + 1 + FOffset.Y);
|
|
SetSelText(TTreeView(Data.Source).Selected.Text);
|
|
end;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetKeywordAttr(Value: TfsFontSettings);
|
|
begin
|
|
FKeywordAttr.Assign(Value);
|
|
UpdateSyntax;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetStringAttr(Value: TfsFontSettings);
|
|
begin
|
|
FStringAttr.Assign(Value);
|
|
UpdateSyntax;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetTextAttr(Value: TfsFontSettings);
|
|
begin
|
|
FTextAttr.Assign(Value);
|
|
UpdateSyntax;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetCommentAttr(Value: TfsFontSettings);
|
|
begin
|
|
FCommentAttr.Assign(Value);
|
|
UpdateSyntax;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetFill(const Value: TBrush);
|
|
begin
|
|
FFill.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetFontSettings(const Value: TfsFontSettings);
|
|
begin
|
|
FFontSettings.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetGutterFill(const Value: TBrush);
|
|
begin
|
|
FGutterFill.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetActiveLine(Line : Integer);
|
|
begin
|
|
FActiveLine := Line;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfsSyntaxMemo.SetAttr(aCanvas: TCanvas; a: TCharAttributes);
|
|
begin
|
|
with aCanvas do
|
|
begin
|
|
Font.Assign(FFontSettings.Font);
|
|
Canvas.Fill.Assign(FFontSettings.Fill);
|
|
|
|
if caText in a then
|
|
begin
|
|
Font.Assign(FTextAttr.Font);
|
|
Canvas.Fill.Assign(FTextAttr.Fill);
|
|
end;
|
|
|
|
if caComment in a then
|
|
begin
|
|
Font.Assign(FCommentAttr.Font);
|
|
Canvas.Fill.Assign(FCommentAttr.Fill);
|
|
end;
|
|
|
|
if caKeyword in a then
|
|
begin
|
|
Font.Assign(FKeywordAttr.Font);
|
|
Canvas.Fill.Assign(FKeywordAttr.Fill);
|
|
end;
|
|
|
|
if caString in a then
|
|
begin
|
|
Font.Assign(FStringAttr.Font);
|
|
Canvas.Fill.Assign(FStringAttr.Fill);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure TfsSyntaxMemo.SetBorder(const Value: TfsBorderSettings);
|
|
begin
|
|
FBorder.Fill.Assign(Value.Fill);
|
|
FBorder.Width := Value.Width;
|
|
end;
|
|
|
|
function TfsSyntaxMemo.GetActiveLine: Integer;
|
|
begin
|
|
Result := FActiveLine;
|
|
end;
|
|
|
|
procedure TfsSynMemoSearch.FormKeyPress(Sender: TObject; var Key: Char);
|
|
begin
|
|
if Key = #13 then
|
|
ModalResult := mrOk;
|
|
end;
|
|
|
|
{ TfsBorderSettings }
|
|
|
|
constructor TfsBorderSettings.Create;
|
|
begin
|
|
FFill := TBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.Silver);
|
|
FWidth := 1;
|
|
end;
|
|
|
|
destructor TfsBorderSettings.Destroy;
|
|
begin
|
|
FFill.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsBorderSettings.SetFill(const Value: TBrush);
|
|
begin
|
|
FFill.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsBorderSettings.SetWidth(const Value: Integer);
|
|
begin
|
|
if Value > 3 then
|
|
FWidth := 3
|
|
else if Value < 0 then
|
|
FWidth := 0
|
|
else
|
|
FWidth := Value;
|
|
end;
|
|
|
|
{ TfsFontSettings }
|
|
|
|
procedure TfsFontSettings.Assign(Source: TPersistent);
|
|
begin
|
|
inherited;
|
|
if Source is TfsFontSettings then
|
|
begin
|
|
Fill.Assign(TfsFontSettings(Source).Fill);
|
|
Font.Assign(TfsFontSettings(Source).Font);
|
|
end;
|
|
end;
|
|
|
|
constructor TfsFontSettings.Create();
|
|
begin
|
|
FFill := TBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.Black);
|
|
FFont := TFont.Create;
|
|
FFont.Family := 'Courier New';
|
|
FFont.Size := 13;
|
|
end;
|
|
|
|
destructor TfsFontSettings.Destroy;
|
|
begin
|
|
FFill.Free;
|
|
FFont.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsFontSettings.SetFill(const Value: TBrush);
|
|
begin
|
|
FFill.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsFontSettings.SetFont(const Value: TFont);
|
|
begin
|
|
FFont.Assign(Value);
|
|
end;
|
|
|
|
initialization
|
|
StartClassGroup(TFmxObject);
|
|
ActivateClassGroup(TFmxObject);
|
|
GroupDescendentsWith(TfsSyntaxMemo, TFmxObject);
|
|
GroupDescendentsWith(TfsBorderSettings, TFmxObject);
|
|
GroupDescendentsWith(TfsFontSettings, TFmxObject);
|
|
|
|
RegisterFmxClasses([TfsBorderSettings, TfsFontSettings]);
|
|
|
|
end.
|