rm_jvhlparser.pas

这是一个功能强大

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvHLParser.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.

Contributor(s): Eswar Prakash R [eswar dott prakash att gmail.com]

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

class       : TJvIParser
description : text parser

Known Issues:
  Some russian comments were translated to english; these comments are marked
  with [translated]

-----------------------------------------------------------------------------}
// $Id: JvHLParser.pas 10454 2006-04-07 19:55:54Z ahuser $

{history:
3.0:
  2003-09-20: (changes by Andreas Hausladen)
    - added a TJvIParserW parser for unicode text
    - added unicode versions of the functions
}

unit rm_JvHLParser;

{$I rm_jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  rm_JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  SysUtils, Classes, Dialogs,
  rm_JclWideStrings,
  rm_JvTypes, rm_JvJCLUtils;

const
  ieBadRemark = 1;

type
  TIParserStyle = (psNone, psPascal, psCpp, psPython, psVB, psHtml, psPerl, psCocoR, psPhp, psSql);

  TJvIParser = class(TObject)
  protected
    FpcProgram: PChar;
    FpcPos: PChar; // Current position [translated]
    FHistory: TStringList;
    FHistorySize: Integer;
    FHistoryPtr: Integer;
    FStyle: TIParserStyle;
    FReturnComments: Boolean;
    function HistoryInd(Index: Integer): Integer;
    function GetHistory(Index: Integer): string;
    function GetPosBeg(Index: Integer): Integer;
    function GetPosEnd(Index: Integer): Integer;
    procedure SetHistorySize(Size: Integer);
    function GetPos: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    { Returns the following token; shifts a current position [translated] }
    function Token: string;
    { Returns the following token to the left of a current position shifts
      a current position to the left [translated]
    function TokenL : string; - It is devilishly difficult to make it *;-( [translated] }
    { Rollback back on the indicated quantity of tokens [translated] }
    procedure RollBack(Index: Integer);
    property History[Index: Integer]: string read GetHistory;
    property PosBeg[Index: Integer]: Integer read GetPosBeg;
    property PosEnd[Index: Integer]: Integer read GetPosEnd;
    property HistorySize: Integer read FHistorySize write SetHistorySize;
    property Pos: Integer read GetPos;
    // (rom) name change needed
    property pcPos: PChar read FpcPos write FpcPos;
    property pcProgram: PChar read FpcProgram write FpcProgram;
    property Style: TIParserStyle read FStyle write FStyle;
    property ReturnComments: Boolean read FReturnComments write FReturnComments;
  end;

  TJvIParserW = class(TObject)
  protected
    FpcProgram: PWideChar;
    FpcPos: PWideChar; // Current position [translated]
    FHistory: TWStrings;
    FHistorySize: Integer;
    FHistoryPtr: Integer;
    FStyle: TIParserStyle;
    FReturnComments: Boolean;
    function HistoryInd(Index: Integer): Integer;
    function GetHistory(Index: Integer): WideString;
    function GetPosBeg(Index: Integer): Integer;
    function GetPosEnd(Index: Integer): Integer;
    procedure SetHistorySize(Size: Integer);
    function GetPos: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    { Returns the following token; shifts a current position [translated] }
    function Token: WideString;
    { Returns the following token to the left of a current position shifts
      a current position to the left [translated]
    function TokenL : string; - It is devilishly difficult to make it *;-( [translated] }
    { Rollback back on the indicated quantity of tokens [translated] }
    procedure RollBack(Index: Integer);
    property History[Index: Integer]: WideString read GetHistory;
    property PosBeg[Index: Integer]: Integer read GetPosBeg;
    property PosEnd[Index: Integer]: Integer read GetPosEnd;
    property HistorySize: Integer read FHistorySize write SetHistorySize;
    property Pos: Integer read GetPos;
    // (rom) name change needed
    property pcPos: PWideChar read FpcPos write FpcPos;
    property pcProgram: PWideChar read FpcProgram write FpcProgram;
    property Style: TIParserStyle read FStyle write FStyle;
    property ReturnComments: Boolean read FReturnComments write FReturnComments;
  end;

  EJvIParserError = class(Exception)
  private
    FErrCode: Integer;
    FPosition: Cardinal;
  public
    constructor Create(AErrCode: Integer; APosition: Cardinal; Dummy: Integer = 0);
    property ErrCode: Integer read FErrCode;
    property Position: Cardinal read FPosition;
  end;

function IsStringConstant(const St: string): Boolean;
function IsIntConstant(const St: string): Boolean;
function IsRealConstant(const St: string): Boolean;
function IsIdentifier(const ID: string): Boolean;
function GetStringValue(const St: string): string;
procedure ParseString(const S: string; Ss: TStrings);

function IsStringConstantW(const St: WideString): Boolean;
function IsIntConstantW(const St: WideString): Boolean;
function IsRealConstantW(const St: WideString): Boolean;
function IsIdentifierW(const ID: WideString): Boolean;
function GetStringValueW(const St: WideString): WideString;
procedure ParseStringW(const S: WideString; Ss: TWStrings);

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile$';
    Revision: '$Revision: 10454 $';
    Date: '$Date: 2006-04-07 12:55:54 -0700 (Fri, 07 Apr 2006) $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  rm_JvConsts;

//=== { EJvIParserError } ====================================================

constructor EJvIParserError.Create(AErrCode: Integer; APosition: Cardinal; Dummy: Integer = 0);
begin
  inherited Create('');
  FErrCode := AErrCode;
  FPosition := APosition;
end;

//=== { TJvIParser } =========================================================

constructor TJvIParser.Create;
begin
  inherited Create;
  FHistory := TStringList.Create;
  HistorySize := 10;
  Style := psPascal;
end;

destructor TJvIParser.Destroy;
begin
  FHistory.Free;
  inherited Destroy;
end;

function TJvIParser.Token: string;
const
  StSkip = [' ', Lf, Cr];
var
  P, F: PChar;
  F1: PChar;
  I: Integer;

  function SkipComments: Boolean;
  begin
    SkipComments := True;
    case P[0] of
      '{':
        if FStyle = psPascal then
        begin
          F := StrScan(P + 1, '}');
          if F = nil then //IParserError(ieBadRemark, P - FpcProgram);
            Exit;
          P := F + 1;
        end;
      '}':
        if FStyle = psPascal then //IParserError(ieBadRemark, P - FpcProgram);
          Exit;
      '(':
        if (FStyle in [psPascal, psCocoR]) and (P[1] = '*') then
        begin
          if P[2] = #0 then
            Exit; // line end
          F := P + 2;
          while True do
          begin
            F := StrScan(F, '*');
            if F = nil then //IParserError(ieBadRemark, P - FpcProgram);
              Exit;
            if F[1] = ')' then
            begin
              Inc(F);
              Break;
            end;
            Inc(F);
          end;
          P := F + 1;
        end;
      '*':
        if FStyle in [psPascal, psCocoR] then
        begin
          if (P[1] = ')') then
            //IParserError(ieBadRemark, P - FpcProgram)
            Exit;
        end
        else
        if FStyle in [psCpp, psPhp] then
          if P[1] = '/' then //IParserError(ieBadRemark, P - FpcProgram);
            Exit;
      '/':
        if (FStyle in [psPascal, psCpp, psCocoR, psPhp]) and (P[1] = '/') then
        begin
          F := StrScan(P + 1, Cr);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        end
        else
        if (FStyle in [psCpp, psCocoR, psPhp, psSQL]) and (P[1] = '*') then
        begin
          if P[2] = #0 then
            Exit; // line end
          F := P + 2;
          while True do
          begin
            F := StrScan(F, '*');
            if F = nil then //IParserError(ieBadRemark, P - FpcProgram);
              Exit;
            if F[1] = '/' then
            begin
              Inc(F);
              Break;
            end;
            Inc(F);
          end;
          P := F + 1;
        end;
      '#':
        if (FStyle in [psPython, psPerl]) { and
           ((P = FpcProgram) or (P[-1] in [Lf, Cr])) }then
        begin
          F := StrScan(P + 1, Cr);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        end;
      '''':
        if FStyle = psVB then
        begin
          F := StrScan(P + 1, Cr);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        end;
      // Support for the SQL -- comments
      '-':
        if (FStyle = psSql) and (P[1] = '-') then
        begin
          F := StrScan(P + 1, Cr);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        end;
      // Support for multiline comments for HTML
      '<':
        if (FStyle = psHtml) and (P[1] = '!') then
        begin
          // we need the next 2 chars to be --
          if (P[2] = #0) or (P[3] = #0) then
            Exit; // line end
          if (P[2] <> '-') and (P[3] <> '-') then
            Exit;
          F := P + 3;
          while True do
          begin
            F := StrScan(F, '-');
            if F = nil then //IParserError(ieBadRemark, P - FpcProgram);
              Exit;
            if (F[1] = '-') and (F[2] = '>') then
            begin
              Inc(F, 2);
              Break;
            end;
            Inc(F);
          end;
          P := F + 1;
        end;
    end;
    SkipComments := False;
  end;

  procedure Return;
  begin
    FpcPos := P;
    FHistory[FHistoryPtr] := Result;
    FHistory.Objects[FHistoryPtr] := TObject(Pos - 1);
    Inc(FHistoryPtr);
    if FHistoryPtr > FHistorySize - 1 then
      FHistoryPtr := 0;
  end;

begin
  { New Token - To begin reading a new token [translated] }
  F := FpcPos;
  P := FpcPos;
  { Firstly skip spaces and remarks }
  repeat
    while P[0] in StSkip do
      Inc(P);
    F1 := P;
    try
      if SkipComments then
        P := StrEnd(F1);
    except
      on E: EJvIParserError do
        if (E.ErrCode = ieBadRemark) and ReturnComments then
          P := StrEnd(F1)
        else
          raise;
    end;
    if ReturnComments and (P > F1) then
    begin
      SetString(Result, F1, P - F1);
      Return;
      Exit;
    end;
    while P[0] in StSkip do
      Inc(P);
  until F1 = P;

  F := P;
  if FStyle <> psHtml then
  begin
    if P[0] in IdentifierFirstSymbols then
    { token }
    begin
      while P[0] in IdentifierSymbols do
        Inc(P);
      SetString(Result, F, P - F);
    end
    else
    if P[0] in DigitSymbols then
    { number }
    begin
      while (P[0] in DigitSymbols) or (P[0] = '.') do
        Inc(P);
      SetString(Result, F, P - F);
    end
    else
    if (Style = psPascal) and (P[0] = '$') and
      (P[1] in HexadecimalSymbols) then
    { pascal hex number }
    begin
      Inc(P);
      while (P[0] in HexadecimalSymbols) do
        Inc(P);
      SetString(Result, F, P - F);
    end
    else
    if (Style = psPerl) and (P[0] in ['$', '@', '%', '&']) then
    { perl identifier }
    begin
      Inc(P);