* inserted in fcl

fcl/shedit/Makefile

@@ -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
+#
+#

fcl/shedit/doc_text.pp

@@ -0,0 +1,269 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}

fcl/shedit/drawing.inc

@@ -0,0 +1,222 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}

fcl/shedit/gtkdemo.pp

@@ -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.

fcl/shedit/keys.inc

@@ -0,0 +1,575 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}

fcl/shedit/sh_pas.pp

@@ -0,0 +1,326 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}

fcl/shedit/sh_xml.pp

@@ -0,0 +1,256 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}

fcl/shedit/shedit.pp

@@ -0,0 +1,372 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}

fcl/shedit/undo.inc

@@ -0,0 +1,149 @@
+{
+  $Id$
+
+  "shedit" - Text editor with syntax highlighting
+  Copyright (C) 1999  Sebastian Guenther ([email protected])
+
+  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
+
+}