PC Plus SuperCD (UK) 2000 March/pcp161b.iso/handson/archive/Issue160/files/NewStreamIn/strin.pas

Pascal/Delphi Source File | 1999-10-18 | 14.3 KB | 453 lines

unit{a test comment with no spaces around it}strin;

(* PC PLUS Sample Delphi syntax-colouring application.

   Illustrates a simple way to read a plain text file containing program code,
   colour it according to its syntax, by adding RTF codes as necessary,
   then fill a RichEdit control with the coloured code.

   Syntax recognised:
   - Delphi keywords
   - Strings
   - Curly-brace comments
   - Starred comments
   - Single-line comments

   Deficiencies:
   - Limited error-handling
     note: this can be improved by adding exception handling when attempting
           to read and write from streams and by testing the 'status'
           parameter after every read-write operation.
   - Could be optimised
     I have not gone to any lengths to fine-tune my code for efficiency. The
     speed of file loading is perfectly adequate with files up to 500K or so.
     With files in excess of a Megabyte, there is a noticable delay - but only
     of a few seconds (on a 333MHz PC), which seems quite reasonable. All the
     same, there are places in the code where the efficiency could certainly
     be improved.

   Author: Huw Collingbourne.

*)

// The following comments have been added to test colour-coding when
// loading this source file.
{ This is a
  2-line comment}
interface
      { 'a string'  (*a starred
         comment *)  inside a standard one  }
(* This is a starred comment *)
(* {a standard comment} inside a starred one        *)
// { standard comment after line comment }
{ // line comment in standard comment }

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ExtCtrls;

const
     // possible values of status parameter
     SUCCESS = 1;
     NOERROR = 2;
     READERROR = 3;

type

  chararray = array[0..255] of char;
     // ReadStatus defines type of the status parameter
  ReadStatus = SUCCESS..READERROR;

  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Panel1: TPanel;
    LoadFileBtn: TButton;
    PlainTextRBtn: TCheckBox;
    procedure LoadFileBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure PlainTextRBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function KeyWord( token : string ) : boolean;
    procedure WriteRTFHeader( ms : TMemoryStream );
    procedure HandleCR(c : char; msout : TMemoryStream);
    procedure HandleSpecialChars( c : char; msout : TMemoryStream );
    procedure processStream( msin, msout : TMemoryStream );
    procedure ReadStream;
    procedure ReadChar( var c : char; msin : TMemoryStream; var status : ReadStatus );
    procedure ReadToken( var token : chararray; msin : TMemoryStream; var c : char; var status : ReadStatus );
    procedure WriteToken( var token : chararray; msout : TMemoryStream; var status : ReadStatus );
    procedure ReadWriteToken( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteComment( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteStarComment( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteLineComment( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteString( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure WriteChar( c : char; msout : TMemoryStream );
    procedure ReadWriteChar( var c : char; msin, msout : TMemoryStream; var status : ReadStatus );
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
       INFILE = 'Strin.pas';
       CR = #13;
       LF = #10;
       CRLF = #13#10;
       TERMINATOR : char = '}';
       SLASH : char = '\';
       PARCODE = '\par ';
       KWCODE = '\fs16\b ';  // bold for keywords
       COMMENTCODE = '\fs16\cf2\b ';  // bold magenta for comments
       STRINGCODE = '\fs16\cf1\b ';  // blue bold for strings
       PLAINCODE = '\plain\fs16\cf0 ';  // plain black for other text
       SPECIALRTFCHARS = ['{','}','\'] ;
       ALPHANUMERIC =['a'..'z', 'A'..'Z', '_', '0'..'9'];
       RTFHEADER = '{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}'+CRLF+'{\f2\fswiss MS Sans Serif;}{\f3\fswiss\fprq2 System;}}'+CRLF;
       RTFCTABLE = '{\colortbl\red0\green0\blue0;\red0\green0\blue255;\red255\green0\blue255;\red0\green128\blue0;}'+CRLF+'\deflang2057\pard\plain\f0\fs16\cf0 ';

  NUMKEYWORDS = 50;
  Keywords : array[0..NUMKEYWORDS] of string =
              ( 'and', 'array', 'as', 'begin', 'case', 'class', 'const',
              'constructor', 'destructor', 'div', 'do', 'downto', 'else',
              'end', 'except', 'file', 'finally', 'for', 'function', 'if',
              'implementation', 'in', 'inherited', 'interface', 'is', 'mod',
              'nil', 'not', 'object', 'of', 'on', 'or', 'private', 'procedure',
              'program', 'property', 'public', 'published', 'repeat', 'set',
              'string', 'then', 'to', 'try', 'type', 'unit', 'until', 'uses',
              'var', 'while', 'with');

function TForm1.KeyWord( token : string ) : boolean;
// if token is a keyword, return true
var
   isKW : boolean;
   i    : integer;
begin
   isKW := false;
   i := 0;
   while ((i <= NUMKEYWORDS) and (isKW = false )) do
   begin
   //!! Test is case-insensitive (OK for Pascal. Change this for C or Java)
      if lowercase(token) = KeyWords[i] then
         isKW := true
      else
         Inc(i);
   end;
   result := isKW;
end;


procedure TForm1.WriteRTFHeader( ms : TMemoryStream );
begin
    try
      ms.WriteBuffer( RTFHEADER, strlen(RTFHEADER) );
      ms.WriteBuffer( RTFCTABLE, strlen(RTFCTABLE) );
   except
      on EWriteError do
         ShowMessage( 'Failed to write header and ctable to stream!' );
   end;
end;

procedure TForm1.HandleCR(c : char; msout : TMemoryStream);
// deal with CR - write rtf '\para' code to stream
begin
   if c = CR then
      msout.WriteBuffer( PARCODE, strlen( PARCODE ) );
end;

procedure TForm1.HandleSpecialChars( c : char; msout : TMemoryStream );
// deal with special RTF chars - add '\'
begin
   if c in SPECIALRTFCHARS then
       msout.WriteBuffer( SLASH, sizeof( SLASH ) )
   else HandleCR( c, msout );
end;

procedure TForm1.WriteChar( c : char; msout : TMemoryStream );
// Write both normal chars and special rtf chars
begin  // deal with slashes and CRs
      HandleSpecialChars(c, msout );
       // then write the char
      msout.WriteBuffer( c, sizeof( c ) );
end;

procedure TForm1.ReadWriteChar( var c : char; msin, msout : TMemoryStream;
                                     var status : ReadStatus );
// write any char that is not written as part of a token, string or comment
begin
   WriteChar( c, msout );
   ReadChar( c, msin, status );
end;

procedure TForm1.ReadChar( var c : char; msin : TMemoryStream;
                           var status : ReadStatus );
begin
  status := NOERROR;
  try
    if msin.position < msin.size then
       msin.ReadBuffer( c, sizeof(c) );    // read one char at a time
  except
    on EReadError do
       status := READERROR;
  end;
end;

procedure TForm1.ReadToken( var token : chararray; msin : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read an alphanumeric token
var
   i : integer;
begin
  status := NOERROR;
  i := 0;
  token := '';
  try
    while (c in ALPHANUMERIC) do
    begin
       token[i] := c;
       INC(i);
       ReadChar( c, msin, status );     // read one char at a time
    end;
    if token <> '' then
       status := SUCCESS;
  except
    on EReadError do
       status := READERROR;
  end;
end;

procedure TForm1.WriteToken( var token : chararray; msout : TMemoryStream; var status : ReadStatus );
begin
   status := NOERROR;
   if KeyWord(token) then
   begin
      msout.WriteBuffer( KWCODE, length( KWCODE ) );
      msout.WriteBuffer( token, length( token ) );
      msout.WriteBuffer( PLAINCODE, length( PLAINCODE ) );
   end
   else
      msout.WriteBuffer( token, length( token ) );
end;


procedure TForm1.ReadWriteToken( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
var
   token : chararray;
begin
   ReadToken(token,msin,c,status);
   if status = SUCCESS then
      WriteToken(token,msout,status);
end;

procedure TForm1.ReadWriteComment( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read and write a standard curly-brace { } comment
begin
  status := NOERROR;
//   try           // !! add error handling here
   if c = '{' then
   begin
     msout.WriteBuffer( COMMENTCODE, strlen( COMMENTCODE ) );
     msout.WriteBuffer( SLASH, sizeof( SLASH ) );
     msout.WriteBuffer( c, sizeof( c ) );
     while (c <> '}') and (msin.position < msin.size) do
     begin
        msin.ReadBuffer( c, sizeof( c ) );
        if c <> '}' then
          WriteChar( c, msout );
     end;
     if msin.position < msin.size then
     begin
        msout.WriteBuffer( SLASH, sizeof( SLASH ) );
        msout.WriteBuffer( c, sizeof( c ) );
        msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
        msin.ReadBuffer( c, sizeof( c ) );
        status := SUCCESS;
     end;
   end; // if c = '{' then
end;

procedure TForm1.ReadWriteStarComment( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read and write a brace-star (* *) comment
var
   c2 : char;
   CommentEnd, StarFound : boolean;
begin
  status := NOERROR;
  c2 := '#';
  CommentEnd := false;
  StarFound := false;
//   try           // !! add error handling
   if c = '(' then
   begin
      ReadChar(c2,msin,status);
      if c2 <> '*' then
      begin        // if not a comment then
          WriteChar( c, msout );
          c := c2; // return c2
      end
      else
      begin       // if this is a comment
        msout.WriteBuffer( COMMENTCODE, strlen( COMMENTCODE ) );
        msout.WriteBuffer( c, sizeof( c ) );
        msout.WriteBuffer( c2, sizeof( c2 ) );
        while not (CommentEnd) and (msin.position < msin.size) do
        begin
           ReadChar( c, msin, status );
           if (c = ')') and StarFound then
              CommentEnd := true
           else
           if c = '*' then
              StarFound := true
           else StarFound := false;
           WriteChar( c, msout );
        end;
        if msin.position < msin.size then
        begin
           msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
           msin.ReadBuffer( c, sizeof( c ) );
      //     status := SUCCESS;
        end;
      end;
      status := SUCCESS;
   end;
end;

procedure TForm1.ReadWriteLineComment( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read and write a single-line // comment
var
   c2 : char;
begin
  status := NOERROR;
  c2 := '#';
//   try           // !! add error handling
   if c = '/' then
   begin
      ReadChar(c2,msin,status);
      if c2 <> '/' then
      begin        // if not a comment then
          WriteChar( c, msout );
          c := c2; // return c2
      end
      else
      begin       // if this is a comment
        msout.WriteBuffer( COMMENTCODE, strlen( COMMENTCODE ) );
        msout.WriteBuffer( c, sizeof( c ) );
        msout.WriteBuffer( c2, sizeof( c2 ) );
        while not (c = CR) and (msin.position < msin.size) do
        begin
           ReadChar( c, msin, status );
           WriteChar( c, msout );
        end;
        if msin.position < msin.size then
        begin
           msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
           msin.ReadBuffer( c, sizeof( c ) );
        end;
      end;
      status := SUCCESS;
   end;
end;


procedure TForm1.ReadWriteString( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
begin
  status := NOERROR;
//   try           // !! add error handling
   if c = '''' then
   begin
     msout.WriteBuffer( STRINGCODE, strlen( STRINGCODE ) );
     msout.WriteBuffer( c, sizeof( c ) );
     c := '#';
     while (c <> '''') and (msin.position < msin.size) do
     begin
        msin.ReadBuffer( c, sizeof( c ) );
        WriteChar( c, msout );
     end;
     if msin.position < msin.size then
     begin
        msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
        msin.ReadBuffer( c, sizeof( c ) );
        status := SUCCESS;
     end;
   end;
end;

procedure TForm1.processStream( msin, msout : TMemoryStream );
var
   c : char;
   status : ReadStatus;
begin
   Screen.Cursor := crHourglass;       // Show hourglass cursor
   c := '#';
   // start by reading 1st char
   if msin.position < msin.size then
      ReadChar(c,msin,status);
   try
      while msin.position < msin.size do     // iterate through input stream
      begin
         ReadWriteToken( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteString( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteComment( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteStarComment( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteLineComment( msin,msout,c,status);
         if status <> SUCCESS then
            ReadWriteChar(c, msin, msout, status );
      end; // while msin.position < msin.size
   finally
     Screen.Cursor := crDefault;    // restore normal cursor
   end;
end;



procedure TForm1.ReadStream;
var
   msin, msout : TMemoryStream;
begin
   msin := TMemoryStream.Create;
   msout := TMemoryStream.Create;
   msin.LoadFromFile(INFILE);
   msin.Position := 0;  // set pos to 0 prior to loading from stream
   msout.Position := 0;
   WriteRTFHeader( msout );
   processStream(msin, msout);
   msout.WriteBuffer(TERMINATOR, sizeof(TERMINATOR)); // terminate RTF buffer
   msout.Position := 0;
   RichEdit1.Lines.LoadFromStream(msout);
   msin.Free;
   msout.Free;
end;

procedure TForm1.LoadFileBtnClick(Sender: TObject);
begin
   ReadStream;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  RichEdit1.Plaintext := false;
  PlainTextRBtn.Checked := RichEdit1.PlainText;
end;

procedure TForm1.PlainTextRBtnClick(Sender: TObject);
begin
   RichEdit1.Plaintext := PlainTextRBtn.Checked;
end;

end.