paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-02 22:30:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* inserted in fcl

Browse Source
This commit is contained in:
peter 1999-10-29 15:59:03 +00:00
parent 00ef632f73
commit afe98da3e3
9 changed files with 2668 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
fcl/shedit/Makefile Normal file
View File

@ -0,0 +1,116 @@
#
# $Id$
# Copyright (c) 1999 by the Free Pascal Development Team
#
# Makefile for shedit
#
# See the file COPYING.FPC, included in this distribution,
# for details about the copyright.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
#####################################################################
# Defaults
#####################################################################
# Default place of the makefile.fpc
DEFAULTFPCDIR=../..
# As default make only the units
DEFAULTUNITS=1
#####################################################################
# Real targets
#####################################################################
UNITOBJECTS=doc_text shedit sh_pas sh_xml
EXEOBJECTS=gtkdemo
#####################################################################
# Common targets
#####################################################################
.PHONY: all clean install info \
staticlib sharedlib libsclean \
staticinstall sharedinstall libinstall \
all: testfpcmake fpc_all
clean: testfpcmake fpc_clean
install: testfpcmake fpc_install
info: testfpcmake fpc_info
staticlib: testfpcmake fpc_staticlib
sharedlib: testfpcmake fpc_sharedlib
libsclean: testfpcmake fpc_libsclean
staticinstall: testfpcmake fpc_staticinstall
sharedinstall: testfpcmake fpc_sharedinstall
libinstall: testfpcmake fpc_libinstall
#####################################################################
# Include default makefile
#####################################################################
# test if FPCMAKE is still valid
ifdef FPCMAKE
ifeq ($(strip $(wildcard $(FPCMAKE))),)
FPCDIR=
FPCMAKE=
endif
endif
ifndef FPCDIR
ifdef DEFAULTFPCDIR
FPCDIR=$(DEFAULTFPCDIR)
endif
endif
ifndef FPCMAKE
ifdef FPCDIR
FPCMAKE=$(FPCDIR)/makefile.fpc
else
FPCMAKE=makefile.fpc
endif
endif
override FPCMAKE:=$(strip $(wildcard $(FPCMAKE)))
ifeq ($(FPCMAKE),)
testfpcmake:
@echo makefile.fpc not found!
@echo Check the FPCMAKE and FPCDIR environment variables.
@exit
else
include $(FPCMAKE)
testfpcmake:
endif
#####################################################################
# Dependencies
#####################################################################
#
# $Log$
# Revision 1.1 1999-10-29 15:59:03 peter
# * inserted in fcl
#
# Revision 1.1 1999/03/16 00:50:29 peter
# + init
#
#

269
fcl/shedit/doc_text.pp Normal file
View File

@ -0,0 +1,269 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// Generic text document class
{$MODE objfpc}
{$M+,H+}
unit doc_text;
interface
uses Classes;
type
PLine = ^TLine;
TLine = packed record
info: Pointer;
flags: LongWord;
len: LongInt; // Length of string in characters
s: PChar;
end;
PLineArray = ^TLineArray;
TLineArray = array[0..0] of TLine;
const
{TLine.flags Syntax Highlighting Flags}
LF_SH_Valid = $01;
LF_SH_Multiline1 = $02;
LF_SH_Multiline2 = $04;
LF_SH_Multiline3 = $08;
LF_SH_Multiline4 = $10;
LF_SH_Multiline5 = $20;
LF_SH_Multiline6 = $40;
LF_SH_Multiline7 = $80;
{Escape character for syntax highlighting (marks start of sh sequence,
next character is color/sh element number, beginning at #1}
LF_Escape = #10;
type
TTextDoc = class;
TDocLineEvent = procedure(Sender: TTextDoc; Line: Integer) of object;
TViewInfo = class(TCollectionItem)
public
OnLineInsert, OnLineRemove: TDocLineEvent;
OnModifiedChange: TNotifyEvent;
end;
TTextDoc = class
protected
FModified: Boolean;
FLineCount: LongInt;
FLines: PLineArray;
FViewInfos: TCollection;
procedure SetModified(AModified: Boolean);
function GetLineText(LineNumber: Integer): String;
procedure SetLineText(LineNumber: Integer; const NewText: String);
function GetLineLen(LineNumber: Integer): Integer;
function GetLineFlags(LineNumber: Integer): Byte;
procedure SetLineFlags(LineNumber: Integer; NewFlags: Byte);
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure LoadFromFile(const filename: String);
procedure InsertLine(BeforeLine: Integer; const s: String);
procedure AddLine(const s: String);
procedure RemoveLine(LineNumber: Integer);
property Modified: Boolean read FModified write SetModified;
property LineCount: Integer read FLineCount;
property LineText[LineNumber: Integer]: String
read GetLineText write SetLineText;
property LineLen[LineNumber: Integer]: Integer read GetLineLen;
property LineFlags[LineNumber: Integer]: Byte
read GetLineFlags write SetLineFlags;
property ViewInfos: TCollection read FViewInfos;
end;
implementation
uses Strings;
constructor TTextDoc.Create;
begin
FLineCount := 0;
FViewInfos := TCollection.Create(TViewInfo);
end;
destructor TTextDoc.Destroy;
begin
Clear;
end;
procedure TTextDoc.Clear;
var
i: Integer;
begin
for i := 0 to FLineCount - 1 do
StrDispose(FLines^[i].s);
FreeMem(FLines);
for i := 0 to FViewInfos.Count - 1 do
if Assigned(TViewInfo(FViewInfos.Items[i]).OnLineRemove) then
TViewInfo(FViewInfos.Items[i]).OnLineRemove(Self, 0);
end;
procedure TTextDoc.InsertLine(BeforeLine: Integer; const s: String);
var
l: PLine;
NewLines: PLineArray;
i: Integer;
begin
if BeforeLine > FLineCount then exit; // *** throw an intelligent exception
GetMem(NewLines, (FLineCount + 1) * SizeOf(TLine));
Move(FLines^, NewLines^, BeforeLine * SizeOf(TLine));
Move(FLines^[BeforeLine], NewLines^[BeforeLine + 1],
(FLineCount - BeforeLine) * SizeOf(TLine));
FreeMem(FLines);
FLines := NewLines;
l := @(FLines^[BeforeLine]);
FillChar(l^, SizeOf(TLine), 0);
l^.len := Length(s);
l^.s := StrNew(PChar(s));
Inc(FLineCount);
for i := 0 to FViewInfos.Count - 1 do
if Assigned(TViewInfo(FViewInfos.Items[i]).OnLineInsert) then
TViewInfo(FViewInfos.Items[i]).OnLineInsert(Self, BeforeLine);
end;
procedure TTextDoc.AddLine(const s: String);
begin
InsertLine(FLineCount, s);
end;
procedure TTextDoc.RemoveLine(LineNumber: Integer);
var
NewLines: PLineArray;
i: Integer;
begin
StrDispose(FLines^[LineNumber].s);
GetMem(NewLines, (FLineCount - 1) * SizeOf(TLine));
Move(FLines^, NewLines^, LineNumber * SizeOf(TLine));
if LineNumber < FLineCount - 1 then
Move(FLines^[LineNumber + 1], NewLines^[LineNumber],
(FLineCount - LineNumber - 1) * SizeOf(TLine));
FreeMem(FLines);
FLines := NewLines;
Dec(FLineCount);
for i := 0 to FViewInfos.Count - 1 do
if Assigned(TViewInfo(FViewInfos.Items[i]).OnLineRemove) then
TViewInfo(FViewInfos.Items[i]).OnLineRemove(Self, LineNumber);
Modified := True;
end;
procedure TTextDoc.LoadFromFile(const filename: String);
var
f: Text;
s, s2: String;
i: Integer;
begin
Clear;
Assign(f, filename);
Reset(f);
while not eof(f) do begin
ReadLn(f, s);
// Expand tabs to spaces
s2 := '';
for i := 1 to Length(s) do
if s[i] = #9 then begin
repeat s2 := s2 + ' ' until (Length(s2) mod 8) = 0;
end else
s2 := s2 + s[i];
AddLine(s2);
end;
Close(f);
end;
procedure TTextDoc.SetModified(AModified: Boolean);
var
i: Integer;
begin
if AModified = FModified then exit;
FModified := AModified;
for i := 0 to FViewInfos.Count - 1 do
if Assigned(TViewInfo(FViewInfos.Items[i]).OnModifiedChange) then
TViewInfo(FViewInfos.Items[i]).OnModifiedChange(Self);
end;
function TTextDoc.GetLineText(LineNumber: Integer): String;
begin
if (LineNumber < 0) or (LineNumber >= FLineCount) then
Result := ''
else
Result := FLines^[LineNumber].s;
end;
procedure TTextDoc.SetLineText(LineNumber: Integer; const NewText: String);
begin
if (FLines^[LineNumber].s = nil) or
(StrComp(FLines^[LineNumber].s, PChar(NewText)) <> 0) then begin
StrDispose(FLines^[LineNumber].s);
FLines^[LineNumber].len := Length(NewText);
FLines^[LineNumber].s := StrNew(PChar(NewText));
Modified := True;
end;
end;
function TTextDoc.GetLineLen(LineNumber: Integer): Integer;
begin
if (LineNumber < 0) or (LineNumber >= FLineCount) then
Result := 0
else
Result := FLines^[LineNumber].len;
end;
function TTextDoc.GetLineFlags(LineNumber: Integer): Byte;
begin
if (LineNumber < 0) or (LineNumber >= FLineCount) then
Result := 0
else
Result := FLines^[LineNumber].flags;
end;
procedure TTextDoc.SetLineFlags(LineNumber: Integer; NewFlags: Byte);
begin
FLines^[LineNumber].flags := NewFlags;
end;
end.
{
$Log$
Revision 1.1 1999-10-29 15:59:03 peter
* inserted in fcl
}

222
fcl/shedit/drawing.inc Normal file
View File

@ -0,0 +1,222 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// Drawing code of TSHTextEdit (renderer for syntax highlighting engine);
// also handles cursor drawing
procedure TSHTextEdit.DoHighlighting(var flags: Byte; source, dest: PChar);
begin
StrCopy(dest, source);
end;
function TSHTextEdit.CalcSHFlags(FlagsIn: Byte; source: String): Byte;
var
s: PChar;
flags: Byte;
begin
GetMem(s, Length(source) * 3 + 4);
flags := FlagsIn;
DoHighlighting(flags, PChar(source), s);
FreeMem(s, Length(source) * 3 + 4);
Result := flags;
end;
procedure TSHTextEdit.HideCursor;
begin
Dec(CursorVisible);
if CursorVisible >= 0 then
Renderer.HideCursor(CursorX, CursorY);
end;
procedure TSHTextEdit.ShowCursor;
begin
Inc(CursorVisible);
if CursorVisible = 1 then
Renderer.ShowCursor(CursorX, CursorY);
end;
procedure TSHTextEdit.ChangeInLine(line: Integer);
var
CurLine: Integer;
OldFlags, NewFlags: Byte;
begin
// Determine how many lines must be redrawn
CurLine := line;
if CurLine = 0 then
NewFlags := 0
else
NewFlags := FDoc.LineFlags[CurLine - 1];
while CurLine < FDoc.LineCount - 1 do begin
NewFlags := CalcSHFlags(NewFlags, FDoc.LineText[CurLine]);
OldFlags := FDoc.LineFlags[CurLine + 1] and not LF_SH_Valid;
FDoc.LineFlags[CurLine + 1] := NewFlags or LF_SH_Valid;
if OldFlags = (NewFlags and not LF_SH_Valid) then break;
Inc(CurLine);
end;
// Redraw all lines with changed SH flags
Renderer.InvalidateLines(line, CurLine);
end;
procedure TSHTextEdit.DrawContent(x1, y1, x2, y2: Integer);
procedure PostprocessOutput(py: Integer);
begin
// Erase free space below the text area
if py < y2 then
Renderer.ClearRect(0, py, x2, y2);
end;
var
i, j, py, LineNumber, CheckLine: Integer;
OrigStr, sh, s, s2: PChar;
i, spos, x: Integer;
flags: Byte;
r: TRect;
InSel: Boolean;
RequestedColor, LastCol: Char;
begin
if (FDoc = nil) or (FDoc.LineCount <= y1) then begin
PostprocessOutput(y1);
exit;
end;
LineNumber := y1;
py := LineNumber;
// Check if syntax highlighting flags are valid:
if (FDoc.LineFlags[LineNumber] and LF_SH_Valid) <> 0 then
flags := FDoc.LineFlags[LineNumber] and not LF_SH_Valid
else begin
// search for last valid line before the first line to be drawn
CheckLine := LineNumber;
while (CheckLine >= 0) and
((FDoc.LineFlags[CheckLine] and LF_SH_Valid) = 0) do Dec(CheckLine);
if CheckLine >= 0 then begin
flags := FDoc.LineFlags[CheckLine] and not LF_SH_Valid;
// Recalc SH flags for all lines between last valid and first visible line
while (CheckLine < LineNumber) do begin
flags := CalcSHFlags(flags, FDoc.LineText[CheckLine]);
FDoc.LineFlags[CheckLine] := flags or LF_SH_Valid;
Inc(CheckLine);
end;
end else
flags := 0;
end;
while (LineNumber < FDoc.LineCount) and (py <= y2) do begin
i := 0;
// Call syntax highlighter for this line
GetMem(sh, FDoc.LineLen[LineNumber] * 3 + 8);
s := sh;
FDoc.LineFlags[LineNumber] := flags or LF_SH_Valid;
OrigStr := PChar(FDoc.LineText[LineNumber]);
DoHighlighting(flags, OrigStr, s);
// Handle current selection
if FSel.IsValid then
if (LineNumber > FSel.OStartY) and (LineNumber < FSel.OEndY) then begin
s[0] := LF_Escape;
s[1] := Chr(shSelected);
StrCopy(@s[2], OrigStr);
end else if OrigStr[0] = #0 then begin
if LineNumber = FSel.OStartY then begin
s[0] := LF_Escape;
s[1] := Chr(shSelected);
s[2] := #0;
end;
end else if (LineNumber = FSel.OStartY) or
(LineNumber = FSel.OEndY) then begin
s2 := StrNew(s);
spos := 0;
i := 0;
x := 0;
if LineNumber > FSel.OStartY then begin
s[0] := LF_Escape;
s[1] := Chr(shSelected);
InSel := True;
spos := 2;
end else
InSel := False;
LastCol := Chr(shDefault);
while True do begin
if s2[i] = LF_Escape then begin
LastCol := s2[i + 1];
if not InSel then begin
s[spos] := LF_Escape;
s[spos + 1] := LastCol;
Inc(spos, 2);
end;
Inc(i, 2);
end else begin
if InSel then begin
if (LineNumber = FSel.OEndY) and (x = FSel.OEndX) then begin
s[spos] := LF_Escape;
s[spos + 1] := LastCol;
Inc(spos, 2);
InSel := False;
end;
end else
if (LineNumber = FSel.OStartY) and (x = FSel.OStartX) then begin
s[spos] := LF_Escape;
s[spos + 1] := Chr(shSelected);
Inc(spos, 2);
InSel := True;
end;
if s2[i] = #0 then break; // only exit of 'while' loop!
s[spos] := s2[i];
Inc(spos);
Inc(i);
Inc(x);
end;
end;
s[spos] := #0;
StrDispose(s2);
end;
Renderer.DrawTextLine(x1, x2, py, s);
FreeMem(sh, FDoc.LineLen[LineNumber] * 3 + 8);
Inc(LineNumber);
Inc(py);
end;
PostprocessOutput(py);
end;
{
$Log$
Revision 1.1 1999-10-29 15:59:04 peter
* inserted in fcl
}

383
fcl/shedit/gtkdemo.pp Normal file
View File

@ -0,0 +1,383 @@
{$MODE objfpc}
{$H+}
program GTKDemo;
uses SysUtils, GDK, GTK, doc_text, SHEdit, sh_pas, sh_xml;
const
colBlack = $000000;
colDarkBlue = $000080;
colBlue = $0000ff;
colDarkGreen = $008000;
colGreen = $00ff00;
colDarkCyan = $008080;
colCyan = $00ffff;
colBrown = $800000;
colRed = $ff0000;
colDarkMagenta = $800080;
colMagenta = $ff00ff;
colDarkYellow = $808000;
colYellow = $ffff00;
colGray = $808080;
colGrey = colGray;
colLightGray = $c0c0c0;
colLightGrey = colLightGray;
colWhite = $ffffff;
colInvalid = $ff000000;
colDefault = $ffffffff;
type
TSHFontStyle = (fsNormal, fsBold, fsItalics, fsBoldItalics);
TSHStyle = record
Name: String[32];
Color, Background: LongWord;
FontStyle: TSHFontStyle;
end;
TSHStyleArray = array[1..1] of TSHStyle; // Notice the 1!
PSHStyleArray = ^TSHStyleArray;
{This class is a kind of widget class which implements the ISHRenderer
interface for drawing syntax highlighted text}
TGtkSHEdit = class(ISHRenderer)
protected
SHStyles: PSHStyleArray;
SHStyleCount: Integer; // # of currently registered styles
shWhitespace: Integer;
CurGCColor: LongWord;
hadj, vadj: PGtkAdjustment;
PaintBox: PGtkWidget;
Edit: TSHTextEdit;
CharW, CharH: Integer;
Font: array[TSHFontStyle] of PGdkFont; // Fonts for content drawing
gc: PGdkGC;
GdkWnd: PGdkWindow;
constructor Create;
procedure SetEdit(AEdit: TSHTextEdit);
procedure SetGCColor(AColor: LongWord);
// ISHRenderer Implemenation:
//procedure InvalidateLines(y1, y2: Integer); override;
// Drawing
procedure ClearRect(x1, y1, x2, y2: Integer); override;
procedure DrawTextLine(x1, x2, y: Integer; s: PChar); override;
// Cursor
//procedure ShowCursor(x, y: Integer); override;
//procedure HideCursor(x, y: Integer); override;
// Scrolling support
//function GetVertPos: Integer; override;
//procedure SetVertPos(y: Integer); override;
//function GetPageHeight: Integer; override;
procedure SetLineCount(count: Integer); override;
// Clipboard support
//function GetClipboard: String; override;
//procedure SetClipboard(Content: String); override;
public
Widget: PGtkWidget; // this is the outer editor widget
function AddSHStyle(AName: String; AColor, ABackground: LongWord;
AStyle: TSHFontStyle): Integer;
end;
TGtkSHTextEdit = class(TGtkSHEdit)
public
constructor Create(ADoc: TTextDoc);
end;
TGtkSHPasEdit = class(TGtkSHEdit)
public
constructor Create(ADoc: TTextDoc);
end;
TGtkSHXMLEdit = class(TGtkSHEdit)
public
constructor Create(ADoc: TTextDoc);
end;
procedure TGtkSHEdit_Expose(GtkWidget: PGtkWidget; event: PGdkEventExpose;
edit: TGtkSHTextEdit); cdecl;
var
x1, y1, x2, y2: Integer;
begin
x1 := event^.area.x div edit.CharW;
y1 := event^.area.y div edit.CharH;
x2 := (event^.area.x + event^.area.width - 1) div edit.CharW;
y2 := (event^.area.y + event^.area.height - 1) div edit.CharH;
{WriteLn(Format('Expose(%d/%d - %d/%d) for %s', [x1, y1, x2, y2, edit.ClassName]));}
edit.GdkWnd := edit.PaintBox^.window;
edit.GC := gdk_gc_new(edit.GdkWnd);
gdk_gc_copy(edit.GC, PGtkStyle(edit.PaintBox^.thestyle)^.
fg_gc[edit.PaintBox^.state]);
edit.Edit.DrawContent(x1, y1, x2, y2);
end;
constructor TGtkSHEdit.Create;
var
lfd: String; // Logical font descriptor
i: Integer;
begin
inherited Create;
// Create fonts
for i := 0 to 3 do begin
lfd := '-*-courier-';
if (i and 1) <> 0 then lfd := lfd + 'bold'
else lfd := lfd + 'medium';
lfd := lfd + '-';
if (i and 2) <> 0 then lfd := lfd + 'i'
else lfd := lfd + 'r';
lfd := lfd + '-normal--14-*-*-*-*-*-iso8859-1';
Font[TSHFontStyle(i)] := gdk_font_load(PChar(lfd));
end;
CharW := gdk_char_width(Font[fsBold], ' ');
CharH := 14 {=FontHeight} + 3; // *** find better way to determine max. cell height
Edit := nil;
// Create scrolled window and drawing area
hadj := PGtkAdjustment(gtk_adjustment_new(0, 0, 200, 1, 10, 100));
vadj := PGtkAdjustment(gtk_adjustment_new(0, 0, 200, 1, 10, 100));
Widget := gtk_scrolled_window_new(hadj, vadj);
PaintBox := gtk_drawing_area_new;
gtk_scrolled_window_add_with_viewport(PGtkScrolledWindow(Widget), PaintBox);
gtk_widget_show(PaintBox);
gtk_signal_connect_after(PGtkObject(PaintBox), 'expose-event',
GTK_SIGNAL_FUNC(@TGtkSHEdit_Expose), self);
gtk_widget_show(Widget);
end;
procedure TGtkSHEdit.SetEdit(AEdit: TSHTextEdit);
begin
Edit := AEdit;
shWhitespace := AddSHStyle('Whitespace', colBlack, colWhite, fsNormal);
Edit.shDefault := AddSHStyle('Default', colBlack, colWhite, fsNormal);
Edit.shSelected := AddSHStyle('Selected', colWhite, colBlack, fsNormal);
end;
function TGtkSHEdit.AddSHStyle(AName: String; AColor, ABackground: LongWord;
AStyle: TSHFontStyle): Integer;
var
NewStyles: PSHStyleArray;
begin
GetMem(NewStyles, SizeOf(TSHStyle) * (SHStyleCount + 1));
Move(SHStyles^, NewStyles^, SizeOf(TSHStyle) * SHStyleCount);
FreeMem(SHStyles);
SHStyles := NewStyles;
Inc(SHStyleCount);
SHStyles^[SHStyleCount].Name := AName;
SHStyles^[SHStyleCount].Color := AColor;
SHStyles^[SHStyleCount].Background := ABackground;
SHStyles^[SHStyleCount].FontStyle := AStyle;
Result := SHStyleCount;
end;
procedure TGtkSHEdit.SetGCColor(AColor: LongWord);
var
c: TGdkColor;
begin
if AColor <> CurGCColor then begin
c.pixel := 0;
c.red := (((AColor shr 16) and 255) * 65535) div 255;
c.green := (((AColor shr 8) and 255) * 65535) div 255;
c.blue := ((AColor and 255) * 65535) div 255;
gdk_colormap_alloc_color(gdk_colormap_get_system, @c, False, True);
gdk_gc_set_foreground(gc, @c);
CurGCColor := AColor;
end;
end;
procedure TGtkSHEdit.ClearRect(x1, y1, x2, y2: Integer);
begin
SetGCColor(SHStyles^[shWhitespace].Background);
gdk_draw_rectangle(PGdkDrawable(GdkWnd), GC, 1,
x1 * CharW, y1 * CharH, (x2 - x1 + 1) * CharW, (y2 - y1 + 1) * CharH);
end;
procedure TGtkSHEdit.DrawTextLine(x1, x2, y: Integer; s: PChar);
var
CurColor: LongWord;
rx1, rx2: Integer;
procedure DoErase;
begin
SetGCColor(CurColor);
gdk_draw_rectangle(PGdkDrawable(GdkWnd), GC, 1,
rx1 * CharW, y * CharH, (rx2 - rx1 + 1) * CharW, CharH);
end;
var
RequestedColor: Char;
i, j, px: Integer;
NewColor: LongWord;
begin
{WriteLn(Format('DrawTextLine(%d) for %s ', [y, ClassName]));}
// Erase the (potentially multi-coloured) background
rx1 := 0;
rx2 := px;
j := 0;
CurColor := SHStyles^[shWhitespace].Background;
while (s[j] <> #0) and (rx2 <= x2) do begin
if s[j] = LF_Escape then begin
NewColor := SHStyles^[Ord(s[j + 1])].Background;
if NewColor = colDefault then
NewColor := SHStyles^[1].Background;
if NewColor <> CurColor then begin
DoErase;
CurColor := NewColor;
end;
Inc(j, 2);
end else begin
Inc(rx2);
Inc(j);
end;
end;
rx2 := x2;
DoErase;
// Draw text line
RequestedColor := #1;
CurGCColor := colInvalid;
i := 0;
px := 0;
while s[0] <> #0 do begin
if s[0] = LF_Escape then begin
RequestedColor := s[1];
Inc(s, 2);
end else if s[0] = #9 then begin
repeat
Inc(px, CharW);
Inc(i);
until (i and 7) = 0;
Inc(s);
end else begin
if (px >= x1) and (px <= x2) then begin
SetGCColor(SHStyles^[Ord(RequestedColor)].Color);
gdk_draw_text(PGdkDrawable(GdkWnd),
Font[SHStyles^[Ord(RequestedColor)].FontStyle], GC, px * CharW,
(y + 1) * CharH, s, 1);
end;
Inc(s);
Inc(i);
Inc(px);
end;
end;
end;
procedure TGtkSHEdit.SetLineCount(count: Integer);
begin
vadj^.upper := (count + 1) * 16;
gtk_adjustment_changed(vadj);
gtk_widget_set_usize(PaintBox, Trunc(hadj^.upper), Trunc(vadj^.upper));
end;
constructor TGtkSHTextEdit.Create(ADoc: TTextDoc);
var
e: TSHTextEdit;
begin
inherited Create;
e := TSHTextEdit.Create(ADoc, Self);
SetEdit(e);
end;
constructor TGtkSHPasEdit.Create(ADoc: TTextDoc);
var
e: TSHPasEdit;
begin
inherited Create;
e := TSHPasEdit.Create(ADoc, Self);
SetEdit(e);
e.shSymbol := AddSHStyle('Symbol', colBrown, colDefault, fsNormal);
e.shKeyword := AddSHStyle('Keyword', colBlack, colDefault, fsBold);
e.shComment := AddSHStyle('Comment', colDarkCyan, colDefault, fsItalics);
e.shDirective := AddSHStyle('Directive', colDarkYellow, colDefault, fsItalics);
e.shNumbers := AddSHStyle('Numbers', colDarkMagenta, colDefault, fsNormal);
e.shCharacters := AddSHStyle('Characters', colDarkBlue, colDefault, fsNormal);
e.shStrings := AddSHStyle('Strings', colBlue, colDefault, fsNormal);
e.shAssembler := AddSHStyle('Assembler', colDarkGreen, colDefault, fsNormal);
end;
constructor TGtkSHXMLEdit.Create(ADoc: TTextDoc);
var
e: TSHXMLEdit;
begin
inherited Create;
e := TSHXMLEdit.Create(ADoc, Self);
SetEdit(e);
e.shTag := AddSHStyle('Tag', colBlack, colDefault, fsBold);
e.shTagName := AddSHStyle('Tag Name', colBlack, colDefault, fsBold);
e.shDefTagName := AddSHStyle('Definition Tag Name', colDarkGreen, colDefault, fsBold);
e.shArgName := AddSHStyle('Argument Name', colBrown, colDefault, fsNormal);
e.shString := AddSHStyle('String', colBlue, colDefault, fsNormal);
e.shReference := AddSHStyle('Reference', colDarkMagenta, colDefault, fsNormal);
e.shInvalid := AddSHStyle('Invalid', colRed, colDefault, fsNormal);
e.shComment := AddSHStyle('Comment', colDarkCyan, colDefault, fsItalics);
e.shCDATA := AddSHStyle('CDATA', colDarkGreen, colDefault, fsNormal);
end;
var
MainWindow, Notebook: PGtkWidget;
Pages: array[0..2] of TGtkSHEdit;
PasDoc, XMLDoc: TTextDoc;
procedure OnMainWindowDestroyed; cdecl;
begin
gtk_main_quit;
end;
begin
gtk_init(@argc, @argv);
// Create main window
MainWindow := gtk_window_new(GTK_WINDOW_TOPLEVEL);
gtk_widget_set_usize(MainWindow, 600, 400);
gtk_window_set_title(PGtkWindow(MainWindow), 'FPC SHEdit GTK Demo');
gtk_signal_connect(PGtkObject(MainWindow), 'destroy', GTK_SIGNAL_FUNC(@OnMainWindowDestroyed), nil);
// Set up documents
PasDoc := TTextDoc.Create; PasDoc.LoadFromFile('gtkdemo.pp');
XMLDoc := TTextDoc.Create; XMLDoc.LoadFromFile('gtkdemo.pp');
// Create notebook pages (editor widgets)
Pages[0] := TGtkSHPasEdit.Create(PasDoc);
Pages[1] := TGtkSHXMLEdit.Create(XMLDoc);
Pages[2] := TGtkSHTextEdit.Create(PasDoc);
// Create notebook
Notebook := gtk_notebook_new;
gtk_notebook_append_page(PGtkNotebook(Notebook), Pages[0].Widget, gtk_label_new('Pascal'));
gtk_notebook_append_page(PGtkNotebook(Notebook), Pages[1].Widget, gtk_label_new('XML'));
gtk_notebook_append_page(PGtkNotebook(Notebook), Pages[2].Widget, gtk_label_new('Text'));
gtk_container_add(PGtkContainer(MainWindow), Notebook);
gtk_widget_show(Notebook);
gtk_widget_show(MainWindow);
gtk_main;
end.

575
fcl/shedit/keys.inc Normal file
View File

@ -0,0 +1,575 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// TSHTextEdit: Implementation of keyboard handling methods
function TSHTextEdit.AddKeyboardAction(AMethod: TKeyboardActionProc;
ADescr: String): TKeyboardActionDescr;
begin
Result := TKeyboardActionDescr(KeyboardActions.Add);
Result.Descr := ADescr;
Result.Method := AMethod;
end;
function TSHTextEdit.AddKeyboardAssignment(AKeyCode: Integer;
AShiftState: TShiftState; AAction: TKeyboardActionDescr): TShortcut;
begin
Result := TShortcut(Shortcuts.Add);
Result.KeyCode := AKeyCode;
Result.ShiftState := AShiftState;
Result.Action := AAction;
end;
procedure TSHTextEdit.AddKeyDef(AMethod: TKeyboardActionProc; ADescr: String;
AKeyCode: Integer; AShiftState: TShiftState);
begin
AddKeyboardAssignment(AKeyCode, AShiftState,
AddKeyboardAction(AMethod, ADescr));
end;
procedure TSHTextEdit.ToggleOverwriteMode;
begin
OverwriteMode := not OverwriteMode; // *** specify signal for change
end;
procedure TSHTextEdit.CursorUp;
var
l1, l2: Integer;
begin
if FCursorY = 0 then
FCursorX := 0
else begin
l1 := FDoc.LineLen[FCursorY];
Dec(FCursorY);
l2 := FDoc.LineLen[FCursorY];
if FCursorX > l2 then
FCursorX := l2;
end;
end;
procedure TSHTextEdit.CursorDown;
var
l1, l2: Integer;
begin
if FCursorY < FDoc.LineCount - 1 then begin
l1 := FDoc.LineLen[FCursorY];
Inc(FCursorY);
l2 := FDoc.LineLen[FCursorY];
if FCursorX > l2 then
FCursorX := l2;
end else
FCursorX := FDoc.LineLen[FCursorY];
end;
procedure TSHTextEdit.CursorLeft;
begin
if FCursorX > 0 then
Dec(FCursorX)
else if FCursorY > 0 then begin
Dec(FCursorY);
FCursorX := FDoc.LineLen[FCursorY];
end;
end;
procedure TSHTextEdit.CursorRight;
begin
Inc(FCursorX);
if FCursorX > FDoc.LineLen[FCursorY] then
if FCursorY < FDoc.LineCount - 1 then begin
Inc(FCursorY);
FCursorX := 0;
end else
FCursorX := FDoc.LineLen[FCursorY];
end;
procedure TSHTextEdit.CursorHome;
begin
FCursorX := 0;
end;
procedure TSHTextEdit.CursorEnd;
begin
FCursorX := FDoc.LineLen[FCursorY];
end;
procedure TSHTextEdit.CursorPageUp;
begin
if FCursorY = 0 then
FCursorX := 0
else begin
Dec(FCursorY, Renderer.PageHeight);
if FCursorY < 0 then FCursorY := 0;
if FCursorX > FDoc.LineLen[FCursorY] then
FCursorX := FDoc.LineLen[FCursorY];
end;
Renderer.VertPos := Renderer.VertPos - Renderer.PageHeight;
end;
procedure TSHTextEdit.CursorPageDown;
begin
if FCursorY = FDoc.LineCount - 1 then
FCursorX := FDoc.LineLen[FCursorY]
else begin
Inc(FCursorY, Renderer.PageHeight);
if FCursorY >= FDoc.LineCount then
FCursorY := FDoc.LineCount - 1;
if FCursorX > FDoc.LineLen[FCursorY] then
FCursorX := FDoc.LineLen[FCursorY];
end;
Renderer.VertPos := Renderer.VertPos + Renderer.PageHeight;
end;
procedure TSHTextEdit.EditDelLeft;
var
s: String;
begin
if FCursorX > 0 then begin
s := FDoc.LineText[FCursorY];
Dec(FCursorX);
AddUndoInfo(TUndoDelLeft.Create(s[FCursorX + 1]), True);
s := Copy(s, 1, FCursorX) + Copy(s, FCursorX + 2, Length(s));
FDoc.LineText[FCursorY] := s;
ChangeInLine(FCursorY);
end else if FCursorY > 0 then begin
FCursorX := FDoc.LineLen[FCursorY - 1];
FDoc.LineText[FCursorY - 1] := FDoc.LineText[FCursorY - 1] +
FDoc.LineText[FCursorY];
Dec(FCursorY);
FDoc.RemoveLine(FCursorY + 1);
AddUndoInfo(TUndoDelLeft.Create(#13), True);
end;
end;
procedure TSHTextEdit.EditDelRight;
var
s: String;
begin
if FCursorX < FDoc.LineLen[FCursorY] then begin
s := FDoc.LineText[FCursorY];
AddUndoInfo(TUndoDelRight.Create(s[FCursorX + 1]), True);
s := Copy(s, 1, FCursorX) + Copy(s, FCursorX + 2, Length(s));
FDoc.LineText[FCursorY] := s;
ChangeInLine(FCursorY);
end else if FCursorY < FDoc.LineCount - 1 then begin
FDoc.LineText[FCursorY] := FDoc.LineText[FCursorY] +
FDoc.LineText[FCursorY + 1];
FDoc.RemoveLine(FCursorY + 1);
AddUndoInfo(TUndoDelRight.Create(#13), True);
end;
end;
procedure TSHTextEdit.EditDelLine;
var
DeletedText: String;
begin
DeletedText := FDoc.LineText[FCursorY];
if FDoc.LineCount = 1 then
FDoc.LineText[FCursorY] := ''
else
FDoc.RemoveLine(FCursorY);
if FCursorY >= FDoc.LineCount then
FCursorY := FDoc.LineCount - 1;
FCursorX := 0;
AddUndoInfo(TUndoDelRight.Create(DeletedText + #13), True);
ChangeInLine(FCursorY);
end;
procedure TSHTextEdit.EditUndo;
var
info: TUndoInfo;
begin
if LastUndoInfo = nil then exit;
info := LastUndoInfo;
LastUndoInfo := LastRedoInfo;
info.DoUndo(Self);
LastRedoInfo := LastUndoInfo;
LastUndoInfo := info;
// Free undo info
if info.Prev <> nil then
info.Prev.Next := info.Next
else
FDoc.Modified := False;
LastUndoInfo := info.Prev;
info.Free;
end;
procedure TSHTextEdit.EditRedo;
var
info: TUndoInfo;
begin
if LastRedoInfo = nil then exit;
info := LastRedoInfo;
info.DoUndo(Self);
// Free redo info
if info.Prev <> nil then
info.Prev.Next := info.Next;
LastRedoInfo := info.Prev;
info.Free;
end;
procedure TSHTextEdit.ClipboardCut;
begin
WriteLn('ClipboardCut: Not implemented yet');
ClipboardCopy;
end;
procedure TSHTextEdit.ClipboardCopy;
var
cbtext: String;
y: Integer;
begin
if FSel.OStartY = FSel.OEndY then
cbtext := Copy(FDoc.LineText[FSel.OStartY], FSel.OStartX + 1, FSel.OEndX - FSel.OStartX)
else begin
cbtext := Copy(FDoc.LineText[FSel.OStartY], FSel.OStartX + 1,
FDoc.LineLen[FSel.OStartY]) + #10;
for y := FSel.OStartY + 1 to FSel.OEndY - 1 do
cbtext := cbtext + FDoc.LineText[y] + #10;
cbtext := cbtext + Copy(FDoc.LineText[FSel.OEndY], 1, FSel.OEndX);
end;
Renderer.SetClipboard(cbtext);
end;
procedure TSHTextEdit.ClipboardPaste;
var
cbtext: String;
begin
cbtext := Renderer.GetClipboard;
ExecKeys(cbtext, True);
end;
procedure TSHTextEdit.KeyReturn; begin end;
function TSHTextEdit.ExecKey(Key: Char; BlockMode: Boolean): Boolean;
var
s, s2: String;
i: Integer;
begin
Result := True;
case Key of
#9: begin
s := FDoc.LineText[FCursorY];
s2 := ' ';
i := 1;
while ((FCursorX + i) mod 4) <> 0 do begin
s2 := s2 + ' ';
Inc(i);
end;
s := Copy(s, 1, FCursorX) + s2 + Copy(s, FCursorX + 1, Length(s));
FDoc.LineText[FCursorY] := s;
Inc(FCursorX, i);
AddUndoInfo(TUndoEdit.Create(i), True);
ChangeInLine(FCursorY);
end;
#13: begin
s := FDoc.LineText[FCursorY];
FDoc.LineText[FCursorY] := Copy(s, 1, FCursorX);
FDoc.InsertLine(FCursorY + 1, Copy(s, FCursorX + 1, Length(s)));
CursorX := 0;
Inc(FCursorY);
AddUndoInfo(TUndoEdit.Create, True);
if not BlockMode then KeyReturn;
end;
#32..#255: begin
s := FDoc.LineText[FCursorY];
if OverwriteMode then
s := Copy(s, 1, FCursorX) + Key + Copy(s, FCursorX + 2, Length(s))
else
s := Copy(s, 1, FCursorX) + Key + Copy(s, FCursorX + 1, Length(s));
FDoc.LineText[FCursorY] := s;
Inc(FCursorX);
AddUndoInfo(TUndoEdit.Create, True);
ChangeInLine(FCursorY);
end;
else Result := False;
end;
end;
procedure TSHTextEdit.ExecKeys(Keys: String; BlockMode: Boolean);
var
s, s2: String;
KeysPos, i: Integer;
Key: Char;
begin
if BlockMode then
AddUndoInfo(TUndoEdit.Create(0), False); // Initialize new undo block
KeysPos := 1;
while KeysPos <= Length(Keys) do begin
case Keys[KeysPos] of
#9: begin
s := FDoc.LineText[FCursorY];
s2 := ' ';
i := 1;
while ((FCursorX + i) mod 4) <> 0 do begin
s2 := s2 + ' ';
Inc(i);
end;
s := Copy(s, 1, FCursorX) + s2 + Copy(s, FCursorX + 1, Length(s));
FDoc.LineText[FCursorY] := s;
Inc(FCursorX, i);
AddUndoInfo(TUndoEdit.Create(i), True);
ChangeInLine(FCursorY);
Inc(KeysPos);
end;
#13, #10: begin
s := FDoc.LineText[FCursorY];
FDoc.LineText[FCursorY] := Copy(s, 1, FCursorX);
FDoc.InsertLine(FCursorY + 1, Copy(s, FCursorX + 1, Length(s)));
CursorX := 0;
Inc(FCursorY);
AddUndoInfo(TUndoEdit.Create, True);
if not BlockMode then KeyReturn;
Inc(KeysPos);
end;
#32..#255: begin
i := 0;
while (KeysPos <= Length(Keys)) and (Keys[KeysPos] >= #32) do begin
Key := Keys[KeysPos];
s := FDoc.LineText[FCursorY];
s := Copy(s, 1, FCursorX) + Key +
Copy(s, FCursorX + 1 + Ord(OverwriteMode), Length(s));
FDoc.LineText[FCursorY] := s;
Inc(FCursorX);
Inc(i);
Inc(KeysPos);
end;
AddUndoInfo(TUndoEdit.Create(i), True);
ChangeInLine(FCursorY);
end;
else Inc(KeysPos);
end;
end;
end;
procedure TSHTextEdit.MultiDelLeft(count: Integer);
var
s: String;
begin
while count > 0 do begin
if FCursorX > 0 then begin
while (FCursorX > 0) and (count > 0) do begin
s := FDoc.LineText[FCursorY];
Dec(FCursorX);
AddUndoInfo(TUndoDelLeft.Create(s[FCursorX + 1]), True);
s := Copy(s, 1, FCursorX) + Copy(s, FCursorX + 2, Length(s));
FDoc.LineText[FCursorY] := s;
Dec(count);
end;
ChangeInLine(FCursorY);
end else if FCursorY > 0 then begin
FCursorX := FDoc.LineLen[FCursorY - 1];
FDoc.LineText[FCursorY - 1] := FDoc.LineText[FCursorY - 1] +
FDoc.LineText[FCursorY];
Dec(FCursorY);
FDoc.RemoveLine(FCursorY + 1);
AddUndoInfo(TUndoDelLeft.Create(#13), True);
Dec(count);
end else break;
end;
end;
procedure TSHTextEdit.KeyPressed(KeyCode: LongWord; ShiftState: TShiftState);
var
RemoveSel: Boolean;
function CheckEditingKeys: Boolean;
procedure CheckSelKeys;
begin
if ssShift in ShiftState then begin
RemoveSel := False;
if not FSel.IsValid then begin
FSel.StartX := LastCursorX;
FSel.StartY := LastCursorY;
end;
FSel.EndX := FCursorX;
FSel.EndY := FCursorY;
end;
end;
begin
if ShiftState * [ssCtrl, ssAlt] = [] then
Result := ExecKey(Chr(KeyCode), False)
else
Result := False;
end;
procedure RedrawArea(x1, y1, x2, y2: Integer);
var
r: TRect;
begin
// WriteLn('Redraw: ', x1, '/', y1, ' - ', x2, '/', y2);
{###if y1 = y2 then begin
r.Left := FLeftIndent + x1 * CharW;
r.Right := FLeftIndent + x2 * CharW;
r.Top := y1 * CharH;
r.Bottom := r.Top + CharH;
PaintBox.Redraw(r);
end else begin
r.Left := FLeftIndent + x1 * CharW;
r.Right := PaintBox.Width;
r.Top := y1 * CharH;
r.Bottom := r.Top + CharH;
PaintBox.Redraw(r);
if y1 < y2 - 1 then begin
r.Left := FLeftIndent;
r.Top := (y1 + 1) * CharH;
r.Bottom := y2 * CharH;
PaintBox.Redraw(r);
end else
r.Left := FLeftIndent;
r.Right := FLeftIndent + x2 * CharW;
r.Top := y2 * CharH;
r.Bottom := r.Top + CharH;
PaintBox.Redraw(r);
end;}
end;
var
i: Integer;
shortcut: TShortcut;
AssignmentMatched, OldSelValid: Boolean;
OldSelStartX, OldSelStartY, OldSelEndX, OldSelEndY: Integer;
begin
// WriteLn('Text Widget: Key pressed: "', Key, '" ', KeyCode);
HideCursor;
LastCursorX := FCursorX;
LastCursorY := FCursorY;
OldSelValid := FSel.IsValid;
if OldSelValid then begin
OldSelStartX := FSel.OStartX;
OldSelStartY := FSel.OStartY;
OldSelEndX := FSel.OEndX;
OldSelEndY := FSel.OEndY;
end;
RemoveSel := True;
// Check for keyboard shortcuts
AssignmentMatched := False;
for i := 0 to Shortcuts.Count - 1 do begin
shortcut := TShortcut(Shortcuts.Items[i]);
if (KeyCode = shortcut.KeyCode) and
(ShiftState * [ssShift, ssCtrl, ssAlt] = shortcut.ShiftState) then begin
shortcut.Action.Method;
AssignmentMatched := True;
break;
end;
end;
if not AssignmentMatched then
if not CheckEditingKeys then RemoveSel := False;
// Check selection
if FSel.IsValid then begin
if (FSel.StartX = FSel.EndX) and (FSel.StartY = FSel.EndY) then
FSel.Clear
end;
//if RemoveSel then FSel.Clear;
//PaintBox.Redraw;
{Write('Sel = ', FSel.StartX, '/', FSel.StartY, ' - ', FSel.EndX, '/', FSel.EndY);
if OldSelValid then WriteLn(' Old = ', OldSelStartX, '/', OldSelStartY, ' - ', OldSelEndX, '/', OldSelEndY)
else WriteLn;}
if RemoveSel then FSel.Clear;
if not OldSelValid then begin
if FSel.IsValid then
RedrawArea(FSel.OStartX, FSel.OStartY, FSel.OEndX, FSel.OEndY);
end else begin
if not FSel.IsValid then
RedrawArea(OldSelStartX, OldSelStartY, OldSelEndX, OldSelEndY)
else begin
// Do OldSel and FSel intersect?
if (OldSelEndY < FSel.OStartY) or (OldSelStartY > FSel.OEndY) or
((OldSelEndY = FSel.OStartY) and (OldSelEndX <= FSel.OStartX)) or
((OldSelStartY = FSel.OEndY) and (OldSelStartX >= FSel.OEndX)) then begin
RedrawArea(OldSelStartX, OldSelStartY, OldSelEndX, OldSelEndY);
RedrawArea(FSel.OStartX, FSel.OStartY, FSel.OEndX, FSel.OEndY);
end else begin
// Intersection => determine smallest possible area(s) to redraw
// 1. Check if the start position has changed
if (OldSelStartX <> FSel.OStartX) or (OldSelStartY <> FSel.OStartY) then
if (OldSelStartY < FSel.OStartY) or ((OldSelStartY = FSel.OStartY) and
(OldSelStartX < FSel.OStartX)) then
RedrawArea(OldSelStartX, OldSelStartY, FSel.OStartX, FSel.OStartY)
else
RedrawArea(FSel.OStartX, FSel.OStartY, OldSelStartX, OldSelStartY);
// 2. Check if end position has changed
if (OldSelEndX <> FSel.OEndX) or (OldSelEndY <> FSel.OEndY) then
if (OldSelEndY < FSel.OEndY) or ((OldSelEndY = FSel.OEndY) and
(OldSelEndX < FSel.OEndX)) then
RedrawArea(OldSelEndX, OldSelEndY, FSel.OEndX, FSel.OEndY)
else
RedrawArea(FSel.OEndX, FSel.OEndY, OldSelEndX, OldSelEndY);
{if OldSelEndY = FSel.OEndY then begin
if OldSelStartX > FSel.OStartX then
RedrawArea(FSel.OStartX, FSel.OEndY, OldSelStartX, FSel.OEndY)
else if OldSelStartX < FSel.OStartX then
RedrawArea(OldSelStartX, FSel.OEndY, FSel.OStartX, FSel.OEndY);
if OldSelEndX < FSel.OEndX then
RedrawArea(OldSelEndX, FSel.OEndY, FSel.OEndX, FSel.OEndY)
else if OldSelEndX > FSel.OEndX then
RedrawArea(FSel.OEndX, FSel.OEndY, OldSelEndX, FSel.OEndY);
end else begin
if OldSelStartY > FSel.OStartY then
RedrawArea(FSel.OStartX, FSel.OStartY, OldSelStartX, OldSelStartY)
else if OldSelStartY < FSel.OStartY then
RedrawArea(OldSelStartX, OldSelStartY, FSel.OStartX, FSel.OStartY);
if OldSelEndY < FSel.OEndY then
RedrawArea(OldSelEndX, OldSelEndY, FSel.OEndX, FSel.OEndY)
else if OldSelEndY > FSel.OEndY then
RedrawArea(FSel.OEndX, FSel.OEndY, OldSelEndX, OldSelEndY);
end;}
end;
end;
end;
ShowCursor;
end;
{
$Log$
Revision 1.1 1999-10-29 15:59:04 peter
* inserted in fcl
}

326
fcl/shedit/sh_pas.pp Normal file
View File

@ -0,0 +1,326 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// viewer class for Pascal source
{$MODE objfpc}
{$H+}
unit sh_pas;
interface
uses doc_text, shedit;
type
TSHPasEdit = class(TSHTextEdit)
protected
procedure DoHighlighting(var flags: Byte; source, dest: PChar); override;
procedure KeyReturn; override;
public
// Syntax highlighter style indices
shSymbol, shKeyword, shComment, shDirective, shNumbers, shCharacters,
shStrings, shAssembler: Integer;
end;
implementation
uses Strings;
const
LF_SH_Comment1 = LF_SH_Multiline1;
LF_SH_Comment2 = LF_SH_Multiline2; { (* Comments}
LF_SH_Asm = LF_SH_Multiline3;
MaxKeywordLength = 15;
MaxKeyword = 61;
KeywordTable: array[0..MaxKeyword] of PChar =
('AND', 'ARRAY', 'ASM', 'ASSEMBLER',
'BEGIN', 'BREAK',
'CASE', 'CONST', 'CONSTRUCTOR', 'CLASS',
'DEFAULT', 'DESTRUCTOR', 'DIV', 'DO', 'DOWNTO',
'ELSE', 'END', 'EXCEPT', 'EXIT',
'FINALIZATION', 'FINALLY', 'FOR', 'FUNCTION',
'GOTO',
'IF', 'IMPLEMENTATION', 'IN', 'INHERITED', 'INITIALIZATION', 'INTERFACE',
'NOT',
'OBJECT', 'OF', 'ON', 'OR', 'OVERRIDE',
'PACKED', 'PRIVATE', 'PROCEDURE', 'PROGRAM', 'PROPERTY', 'PROTECTED',
'PUBLIC', 'PUBLISHED',
'RAISE', 'READ', 'RECORD', 'REPEAT', 'RESOURCESTRING',
'SET',
'THEN', 'TRY', 'TYPE',
'UNIT', 'UNTIL', 'USES',
'VAR', 'VIRTUAL',
'WHILE', 'WITH', 'WRITE',
'XOR');
KeywordAsmIndex = 2;
procedure TSHPasEdit.KeyReturn;
var
s: String;
i, count: Integer;
begin
// Get # of spaces in front of previous line
s := FDoc.LineText[CursorY - 1];
i := 1; count := 0;
while (i <= Length(s)) and (s[i] = ' ') do begin
Inc(i);
Inc(count);
end;
FDoc.LineText[CursorY] := Copy(s, 1, count) + FDoc.LineText[CursorY];
Inc(FCursorX, count);
AddUndoInfo(TUndoEdit.Create(count), True);
ChangeInLine(CursorY);
end;
procedure TSHPasEdit.DoHighlighting(var flags: Byte; source, dest: PChar);
var
dp: Integer; {Destination postion - current offset in dest}
LastSHPos: Integer; {Position of last highlighting character, or 0}
procedure AddSH(sh: Byte);
begin
if (LastSHPos > 0) and (dp = LastSHPos + 1) then Dec(dp, 2);
dest[dp] := LF_Escape; Inc(dp);
LastSHPos := dp;
dest[dp] := Chr(sh); Inc(dp);
end;
procedure PutChar;
begin
dest[dp] := source[0]; Inc(dp); Inc(source);
end;
procedure ProcessComment1;
begin
while source[0] <> #0 do begin
if source[0] = '}' then begin
PutChar;
flags := flags and not LF_SH_Comment1;
AddSH(shDefault);
break;
end;
PutChar;
end;
end;
procedure ProcessComment2;
begin
while source[0] <> #0 do begin
if (source[0] = '*') and (source[1] = ')') then begin
PutChar; PutChar;
flags := flags and not LF_SH_Comment2;
AddSH(shDefault);
break;
end;
PutChar;
end;
end;
{ Checks if we are at the beginning of a comment (or directive) and processes
all types of comments and directives, or returns False }
function CheckForComment: Boolean;
begin
Result := True;
if source[0] = '{' then begin
if source[1] = '$' then
AddSH(shDirective)
else
AddSH(shComment);
PutChar;
flags := flags or LF_SH_Comment1;
ProcessComment1;
end else if (source[0] = '(') and (source[1] = '*') then begin
AddSH(shComment);
PutChar; PutChar;
flags := flags or LF_SH_Comment2;
ProcessComment2;
end else if (source[0] = '/') and (source[1] = '/') then begin
AddSH(shComment);
repeat PutChar until source[0] = #0;
AddSH(shDefault);
end else
Result := False;
end;
procedure ProcessAsm;
var
LastChar: Char;
begin
LastChar := ' ';
while source[0] <> #0 do begin
if (LastChar in [' ', #9, #10, #13]) and
(UpCase(source[0]) = 'E') and (UpCase(source[1]) = 'N') and
(UpCase(source[2]) = 'D') then begin
AddSH(shKeyword);
PutChar; PutChar; PutChar;
flags := flags and not LF_SH_Asm;
AddSH(shDefault);
break;
end else
if CheckForComment then LastChar := ' '
else begin
LastChar := source[0];
PutChar;
end;
end;
end;
procedure ProcessSymbol;
begin
AddSH(shSymbol);
if (source[0] = ':') and (source[1] = '=') then
PutChar;
PutChar;
AddSH(shDefault);
end;
function CheckForKeyword: Boolean;
var
keyword, ukeyword: array[0..MaxKeywordLength] of Char;
i, j: Integer;
begin
i := 0;
while (source[i] <> #0) and (i < MaxKeywordLength) and
(source[i] in ['0'..'9', 'A'..'Z', 'a'..'z']) do begin
keyword[i] := source[i];
ukeyword[i] := UpCase(source[i]);
Inc(i);
end;
keyword[i] := #0; ukeyword[i] := #0;
Result := False;
if i < MaxKeywordLength then
for j := 0 to MaxKeyword do
if StrIComp(KeywordTable[j], ukeyword) = 0 then begin
Result := True; break;
end;
if not Result then exit;
Inc(source, i);
AddSH(shKeyword);
StrCopy(dest + dp, keyword);
Inc(dp, i);
if j <> KeywordAsmIndex then
AddSH(shDefault)
else begin
AddSH(shAssembler);
flags := flags or LF_SH_Asm;
ProcessAsm;
end;
end;
var
StringLength: Integer;
begin
dp := 0;
LastSHPos := 0;
if (flags and LF_SH_Comment1) <> 0 then begin
AddSH(shComment);
ProcessComment1;
end;
if (flags and LF_SH_Comment2) <> 0 then begin
AddSH(shComment);
ProcessComment2;
end;
if (flags and LF_SH_Asm) <> 0 then begin
AddSH(shAssembler);
ProcessAsm;
end;
while source[0] <> #0 do begin
if CheckForComment then continue;
case source[0] of
',', ';', ':', '.', '(', ')', '[', ']', '<', '>', '=',
'*', '/', '+', '-', '^', '&', '@': ProcessSymbol;
'#': begin
AddSH(shCharacters);
PutChar;
if source[0] = '$' then PutChar;
while (source[0] >= '0') and (source[0] <= '9') do PutChar;
AddSH(shDefault);
end;
'$': begin
AddSH(shNumbers);
PutChar;
while source[0] in ['0'..'9', 'A'..'F', 'a'..'f'] do PutChar;
AddSH(shDefault);
end;
'0'..'9': begin
AddSH(shNumbers);
PutChar;
while (source[0] >= '0') and (source[0] <= '9') do PutChar;
AddSH(shDefault);
end;
'''': begin
AddSH(shStrings);
PutChar;
StringLength := 0;
while source[0] <> #0 do begin
if source[0] = '''' then
if source[1] = '''' then PutChar
else begin
PutChar; break;
end;
Inc(StringLength);
PutChar;
end;
if StringLength = 1 then
dest[LastSHPos] := Chr(shCharacters);
AddSH(shDefault);
end;
'_', 'A'..'Z', 'a'..'z':
if not CheckForKeyword then
repeat
PutChar
until not (source[0] in ['0'..'9', '_', 'A'..'Z', 'a'..'z']);
else
PutChar; // = found an invalid char!
end;
end;
dest[dp] := #0;
end;
end.
{
$Log$
Revision 1.1 1999-10-29 15:59:04 peter
* inserted in fcl
}

256
fcl/shedit/sh_xml.pp Normal file
View File

@ -0,0 +1,256 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// viewer class for XML files
{$MODE objfpc}
{$H+}
unit sh_xml;
interface
uses doc_text, shedit;
type
TSHXMLEdit = class(TSHTextEdit)
protected
procedure DoHighlighting(var flags: Byte; source, dest: PChar); override;
public
// Syntax highlighter style indices
shTag, shTagName, shDefTagName, shArgName, shString, shReference,
shInvalid, shComment, shCDATA: Integer;
end;
implementation
uses Strings;
const
LF_SH_Tag = LF_SH_Multiline1;
LF_SH_Comment = LF_SH_Multiline2;
LF_SH_String1 = LF_SH_Multiline3; // Single quotation mark
LF_SH_String2 = LF_SH_Multiline4; // Double quotation mark
LF_SH_CDATA = LF_SH_Multiline5;
procedure TSHXMLEdit.DoHighlighting(var flags: Byte; source, dest: PChar);
var
dp: Integer; {Destination postion - current offset in dest}
LastSHPos: Integer; {Position of last highlighting character, or 0}
procedure AddSH(sh: Byte);
begin
if (LastSHPos > 0) and (dp = LastSHPos + 1) then Dec(dp, 2);
dest[dp] := LF_Escape; Inc(dp);
LastSHPos := dp;
dest[dp] := Chr(sh); Inc(dp);
end;
procedure PutChar;
begin
dest[dp] := source[0]; Inc(dp); Inc(source);
end;
procedure ProcessComment;
begin
flags := flags or LF_SH_Comment;
AddSH(shComment);
while source[0] <> #0 do begin
if (source[0] = '-') and (source[1] = '-') and (source[2] = '>') then begin
PutChar; PutChar; PutChar;
flags := flags and not LF_SH_Comment;
AddSH(shDefault);
break;
end;
PutChar;
end;
end;
procedure ProcessReference;
begin
AddSH(shReference);
while source[0] <> #0 do begin
if source[0] = ';' then begin
PutChar;
AddSH(shDefault);
break;
end else if (source[0] = '''') or (source[0] = '"') then begin
AddSH(shString);
break;
end else
PutChar;
end;
end;
procedure ProcessString(EndChar: Char);
begin
while source[0] <> #0 do begin
if source[0] = EndChar then begin
PutChar;
AddSH(shDefault);
flags := flags and not (LF_SH_String1 or LF_SH_String2);
break;
end else if source[0] = '&' then
ProcessReference
else
PutChar;
end;
end;
procedure ProcessTagContd;
var
c: Char;
begin
while source[0] <> #0 do begin
if (source[0] in ['/', '?']) and (source[1] = '>') then begin
AddSH(shTag);
PutChar;
PutChar;
AddSH(shDefault);
flags := flags and not LF_SH_Tag;
break;
end else if (source[0] = '>') then begin
AddSH(shTag);
PutChar;
AddSH(shDefault);
flags := flags and not LF_SH_Tag;
break;
end else if (source[0] = '''') or (source[0] = '"') then begin
c := source[0];
if source[0] = '''' then
flags := flags or LF_SH_String1
else
flags := flags or LF_SH_String2;
AddSH(shString);
PutChar;
ProcessString(c);
end else if source[0] in [#9, ' ', '=', '(', ')', '+', '*', '?', ','] then begin
AddSH(shDefault);
PutChar;
end else begin
AddSH(shArgName);
PutChar;
end;
end;
end;
procedure ProcessTag;
begin
flags := flags or LF_SH_Tag;
AddSH(shTag);
PutChar;
if source[0] = '/' then PutChar;
if (source[0] = '!') or (source[0] = '?') then
AddSH(shDefTagName)
else
AddSH(shTagName);
while not (source[0] in [#0, ' ', '/', '>']) do
PutChar;
AddSH(shDefault);
ProcessTagContd;
end;
procedure ProcessCDATAContd;
begin
AddSH(shCDATA);
while source[0] <> #0 do begin
if (source[0] = ']') and (source[1] = ']') and
(source[2] = '>') then begin
AddSH(shTag);
PutChar; PutChar; PutChar;
AddSH(shDefault);
flags := flags and not LF_SH_CDATA;
break;
end;
PutChar;
end;
end;
procedure ProcessCDATA;
var
i: Integer;
begin
flags := flags or LF_SH_CDATA;
AddSH(shTag);
for i := 1 to 9 do PutChar;
ProcessCDATAContd;
end;
begin
dp := 0;
LastSHPos := 0;
if (flags and LF_SH_Comment) <> 0 then begin
AddSH(shComment);
ProcessComment;
end;
if (flags and LF_SH_String1) <> 0 then begin
AddSH(shString);
ProcessString('''');
end;
if (flags and LF_SH_String2) <> 0 then begin
AddSH(shString);
ProcessString('"');
end;
if (flags and LF_SH_Tag) <> 0 then
ProcessTagContd;
if (flags and LF_SH_CDATA) <> 0 then
ProcessCDATAContd;
while source[0] <> #0 do begin
case source[0] of
'<':
if (source[1] = '!') and (source[2] = '-') and (source[3] = '-') then
ProcessComment
else if (source[1] = '!') and (source[2] = '[') and (source[3] = 'C')
and (source[4] = 'D') and (source[5] = 'A') and (source[6] = 'T')
and (source[7] = 'A') and (source[8] = '[') then
ProcessCDATA
else
ProcessTag;
'&': ProcessReference;
else
PutChar;
end;
end;
dest[dp] := #0;
end;
end.
{
$Log$
Revision 1.1 1999-10-29 15:59:04 peter
* inserted in fcl
}

372
fcl/shedit/shedit.pp Normal file
View File

@ -0,0 +1,372 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// ===================================================================
// Generic text editor widget with syntax highlighting capabilities
// ===================================================================
{$MODE objfpc}
{$H+}
unit shedit;
interface
uses
Classes, doc_text;
type
TSHTextEdit = class;
// -------------------------------------------------------------------
// Keyboard/action assignment handling
// -------------------------------------------------------------------
TKeyboardActionProc = procedure of object;
TKeyboardActionDescr = class(TCollectionItem)
public
Descr: String; // Human readable description
Method: TKeyboardActionProc;
end;
TShortcut = class(TCollectionItem)
public
KeyCode: Integer;
ShiftState: TShiftState;
Action: TKeyboardActionDescr;
end;
// -------------------------------------------------------------------
// Undo/redo buffer stuff
// -------------------------------------------------------------------
TUndoInfo = class;
TUndoInfo = class
Prev, Next: TUndoInfo;
CursorX, CursorY: Integer;
function Merge(AEdit: TSHTextEdit; AInfo: TUndoInfo): Boolean; virtual;
procedure DoUndo(AEdit: TSHTextEdit); virtual; abstract;
end;
TUndoEdit = class(TUndoInfo)
NumOfChars: Integer;
constructor Create;
constructor Create(ANumOfChars: Integer);
function Merge(AEdit: TSHTextEdit; AInfo: TUndoInfo): Boolean; override;
procedure DoUndo(AEdit: TSHTextEdit); override;
end;
TUndoDelLeft = class(TUndoInfo)
DeletedString: String;
constructor Create(const ADeletedString: String);
function Merge(AEdit: TSHTextEdit; AInfo: TUndoInfo): Boolean; override;
procedure DoUndo(AEdit: TSHTextEdit); override;
end;
TUndoDelRight = class(TUndoDelLeft)
procedure DoUndo(AEdit: TSHTextEdit); override;
end;
// -------------------------------------------------------------------
// Selection support
// -------------------------------------------------------------------
TSelection = class
public
constructor Create;
procedure Clear;
StartX, StartY, EndX, EndY: Integer;
function IsValid: Boolean;
// Ordered coordinates: swaps start and end if necessary
function OStartX: Integer;
function OStartY: Integer;
function OEndX: Integer;
function OEndY: Integer;
end;
// -------------------------------------------------------------------
// SHRenderer interface
// -------------------------------------------------------------------
ISHRenderer = class
procedure InvalidateLines(y1, y2: Integer); virtual; abstract;
// Drawing
procedure ClearRect(x1, y1, x2, y2: Integer); virtual; abstract;
procedure DrawTextLine(x1, x2, y: Integer; s: PChar); virtual; abstract;
// Cursor
procedure ShowCursor(x, y: Integer); virtual; abstract;
procedure HideCursor(x, y: Integer); virtual; abstract;
// Scrolling support
function GetVertPos: Integer; virtual; abstract;
procedure SetVertPos(y: Integer); virtual; abstract;
function GetPageHeight: Integer; virtual; abstract;
procedure SetLineCount(count: Integer); virtual; abstract;
property VertPos: Integer read GetVertPos write SetVertPos;
property PageHeight: Integer read GetPageHeight;
property LineCount: Integer write SetLineCount;
// Clipboard support
function GetClipboard: String; virtual; abstract;
procedure SetClipboard(Content: String); virtual; abstract;
end;
// -------------------------------------------------------------------
// SHTextEdit: The main editor class
// -------------------------------------------------------------------
TShortcutEvent = procedure of object;
TSHTextEdit = class
protected
// ===== Internally used stuff
ViewInfo: TViewInfo; // Connection to document
CursorVisible: Integer;
OverwriteMode: Boolean;
LastUndoInfo, LastRedoInfo: TUndoInfo; // tails of double linked lists
FSel: TSelection;
// OnKeyPressed saves the cursor position before calling key handlers
LastCursorX, LastCursorY: Integer;
function CalcSHFlags(FlagsIn: Byte; source: String): Byte;
procedure HideCursor;
procedure ShowCursor;
procedure ChangeInLine(line: Integer); // Redraws screen where necessary
procedure AddUndoInfo(AInfo: TUndoInfo; CanMerge: Boolean);
// The default implementation does not perform any syntax highlighting:
procedure DoHighlighting(var flags: Byte; source, dest: PChar); virtual;
// ===== Properties
FDoc: TTextDoc; // Document object for text
FCursorX, FCursorY: Integer; // 0/0 = upper left corner
FOnModifiedChange: TNotifyEvent;
FRenderer: ISHRenderer;
procedure SetCursorX(NewCursorX: Integer);
procedure SetCursorY(NewCursorY: Integer);
procedure ModifiedChanged(Sender: TObject);
procedure LineInserted(Sender: TTextDoc; Line: Integer); virtual;
procedure LineRemoved(Sender: TTextDoc; Line: Integer); virtual;
function ExecKey(Key: Char; BlockMode: Boolean): Boolean;
procedure ExecKeys(Keys: String; BlockMode: Boolean);
procedure MultiDelLeft(Count: Integer);
procedure CursorUp;
procedure CursorDown;
procedure CursorLeft;
procedure CursorRight;
procedure CursorHome;
procedure CursorEnd;
procedure CursorPageUp;
procedure CursorPageDown;
// Keyboard command handlers
procedure ToggleOverwriteMode;
procedure EditDelLeft;
procedure EditDelRight;
procedure EditDelLine;
procedure EditUndo;
procedure EditRedo;
procedure ClipboardCut;
procedure ClipboardCopy;
procedure ClipboardPaste;
// Customizable keyboard handlers
procedure KeyReturn; virtual;
public
constructor Create(ADoc: TTextDoc; ARenderer: ISHRenderer); virtual;
function AddKeyboardAction(AMethod: TKeyboardActionProc;
ADescr: String): TKeyboardActionDescr;
function AddKeyboardAssignment(AKeyCode: Integer; AShiftState: TShiftState;
AAction: TKeyboardActionDescr): TShortcut;
procedure AddKeyDef(AMethod: TKeyboardActionProc; ADescr: String;
AKeyCode: Integer; AShiftState: TShiftState);
procedure DrawContent(x1, y1, x2, y2: Integer);
procedure KeyPressed(KeyCode: LongWord; ShiftState: TShiftState); virtual;
KeyboardActions: TCollection;
Shortcuts: TCollection;
shDefault, shSelected: Integer;
property Doc: TTextDoc read FDoc;
property CursorX: Integer read FCursorX write SetCursorX;
property CursorY: Integer read FCursorY write SetCursorY;
property OnModifiedChange: TNotifyEvent
read FOnModifiedChange write FOnModifiedChange;
property Renderer: ISHRenderer read FRenderer;
end;
implementation
uses
Sysutils;
{$INCLUDE undo.inc}
{$INCLUDE keys.inc}
{$INCLUDE drawing.inc}
constructor TSelection.Create;
begin
inherited Create;
Clear;
end;
function TSelection.IsValid: Boolean;
begin
Result := StartX <> -1;
end;
function TSelection.OStartX: Integer;
begin
if (StartY > EndY) or ((StartY = EndY) and (StartX > EndX)) then
Result := EndX
else
Result := StartX;
end;
function TSelection.OStartY: Integer;
begin
if (StartY > EndY) or ((StartY = EndY) and (StartX > EndX)) then
Result := EndY
else
Result := StartY;
end;
function TSelection.OEndX: Integer;
begin
if (StartY > EndY) or ((StartY = EndY) and (StartX > EndX)) then
Result := StartX
else
Result := EndX;
end;
function TSelection.OEndY: Integer;
begin
if (StartY > EndY) or ((StartY = EndY) and (StartX > EndX)) then
Result := StartY
else
Result := EndY;
end;
procedure TSelection.Clear;
begin
StartX := -1;
StartY := -1;
EndX := -1;
EndY := -1;
end;
constructor TSHTextEdit.Create(ADoc: TTextDoc; ARenderer: ISHRenderer);
var
i: Integer;
begin
FDoc := ADoc;
// The document must not be empty
if FDoc.LineCount = 0 then
FDoc.AddLine('');
ViewInfo := TViewInfo(FDoc.ViewInfos.Add);
ViewInfo.OnLineInsert := @LineInserted;
ViewInfo.OnLineRemove := @LineRemoved;
ViewInfo.OnModifiedChange := @ModifiedChanged;
FRenderer := ARenderer;
FSel := TSelection.Create;
KeyboardActions := TCollection.Create(TKeyboardActionDescr);
Shortcuts := TCollection.Create(TShortcut);
FRenderer.SetLineCount(FDoc.LineCount);
end;
procedure TSHTextEdit.ModifiedChanged(Sender: TObject);
begin
if Assigned(OnModifiedChange) then
OnModifiedChange(Self);
end;
procedure TSHTextEdit.SetCursorX(NewCursorX: Integer);
begin
FCursorX := NewCursorX;
HideCursor;
ShowCursor;
end;
procedure TSHTextEdit.SetCursorY(NewCursorY: Integer);
begin
FCursorY := NewCursorY;
HideCursor;
ShowCursor;
end;
procedure TSHTextEdit.LineInserted(Sender: TTextDoc; Line: Integer);
begin
Renderer.LineCount := FDoc.LineCount;
ChangeInLine(Line);
end;
procedure TSHTextEdit.LineRemoved(Sender: TTextDoc; Line: Integer);
begin
LineInserted(Sender, Line);
end;
end.
{
$Log$
Revision 1.1 1999-10-29 15:59:04 peter
* inserted in fcl
}

149
fcl/shedit/undo.inc Normal file
View File

@ -0,0 +1,149 @@
{
$Id$
"shedit" - Text editor with syntax highlighting
Copyright (C) 1999 Sebastian Guenther (sguenther@gmx.de)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
// TSHTextEdit: Undo/Redo support
function TUndoInfo.Merge(AEdit: TSHTextEdit; AInfo: TUndoInfo): Boolean;
begin
Result := False;
end;
constructor TUndoEdit.Create;
begin
inherited Create;
NumOfChars := 1;
end;
constructor TUndoEdit.Create(ANumOfChars: Integer);
begin
inherited Create;
NumOfChars := ANumOfChars;
end;
function TUndoEdit.Merge(AEdit: TSHTextEdit; AInfo: TUndoInfo): Boolean;
begin
// if (CursorX <> AEdit.CursorX - TUndoEdit(AInfo).NumOfChars) or
// (CursorY <> AEdit.CursorY) then exit(False);
Inc(NumOfChars, TUndoEdit(AInfo).NumOfChars);
if AEdit.CursorY = CursorY + 1 then begin
CursorX := 0;
Inc(CursorY);
end else
Inc(CursorX, TUndoEdit(AInfo).NumOfChars);
Result := True;
end;
procedure TUndoEdit.DoUndo(AEdit: TSHTextEdit);
begin
AEdit.FCursorX := CursorX;
AEdit.FCursorY := CursorY;
AEdit.MultiDelLeft(NumOfChars);
end;
constructor TUndoDelLeft.Create(const ADeletedString: String);
begin
inherited Create;
DeletedString := ADeletedString;
end;
function TUndoDelLeft.Merge(AEdit: TSHTextEdit; AInfo: TUndoInfo): Boolean;
var
l: Integer;
begin
if TUndoDelLeft(AInfo).
DeletedString[Length(TUndoDelLeft(AInfo).DeletedString)] = #13 then
exit(False);
l := Length(TUndoDelLeft(AInfo).DeletedString);
if CursorY <> AEdit.CursorY then exit(False);
if CursorX = AEdit.CursorX + l then begin
DeletedString := TUndoDelLeft(AInfo).DeletedString + DeletedString;
Dec(CursorX, l);
end else if CursorX = AEdit.CursorX then
DeletedString := DeletedString + TUndoDelLeft(AInfo).DeletedString
else
exit(False);
Result := True;
end;
procedure TUndoDelLeft.DoUndo(AEdit: TSHTextEdit);
begin
AEdit.FCursorX := CursorX;
AEdit.FCursorY := CursorY;
AEdit.ExecKeys(DeletedString, False);
end;
procedure TUndoDelRight.DoUndo(AEdit: TSHTextEdit);
var
OldX, OldY: Integer;
begin
OldX := CursorX;
OldY := CursorY;
AEdit.FCursorX := CursorX;
AEdit.FCursorY := CursorY;
AEdit.ExecKeys(DeletedString, False);
AEdit.FCursorX := OldX;
AEdit.FCursorY := OldY;
end;
procedure TSHTextEdit.AddUndoInfo(AInfo: TUndoInfo; CanMerge: Boolean);
var
ok: Boolean;
info: TUndoInfo;
begin
ok := False;
info := LastUndoInfo;
if CanMerge and Assigned(info) and (info.ClassType = AInfo.ClassType) then begin
if info.Merge(Self, AInfo) then begin
AInfo.Free;
AInfo := info;
ok := True;
end;
end;
if not ok then begin
if LastUndoInfo = nil then
LastUndoInfo := AInfo
else begin
AInfo.Prev := LastUndoInfo;
LastUndoInfo.Next := AInfo;
LastUndoInfo := AInfo;
end;
AInfo.CursorX := FCursorX;
AInfo.CursorY := FCursorY;
end;
end;
{
$Log$
Revision 1.1 1999-10-29 15:59:04 peter
* inserted in fcl
}