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 <[e-mail]>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.
Contributor(s):
Last Modified: 2002-07-04
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]
-----------------------------------------------------------------------------}
{$I JVCL.Inc}
unit JvHLParser;
interface
uses
  SysUtils, Classes;
const
  ieBadRemark = 1;
type
  TIParserStyle = (psNone, psPascal, psCpp, psPython, psVB, psHtml, psPerl, psCocoR, psPhp);
  TJvIParser = class
  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;
  EJvIParserError = class(Exception)
  public
    ErrCode: Integer;
    Pos: Cardinal;
    constructor Create(AErrCode: Integer; APos: Cardinal);
  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);
implementation
uses
  JvCtlConst;
{$IFDEF Delphi}
type
  TSetOfChar = set of Char;
{$ENDIF Delphi}
{$IFDEF CBUILDER}
type
  TSetOfChar = string;
{$ENDIF CBUILDER}

function CharInSet(const Ch: Char; const SetOfChar: TSetOfChar): Boolean;
begin
{$IFDEF Delphi}
  Result := Ch in SetOfChar;
{$ENDIF Delphi}
{$IFDEF CBUILDER}
  Result := Pos(Ch, SetOfChar) > 0;
{$ENDIF CBUILDER}
end;
//=== EJvIParserError ========================================================

constructor EJvIParserError.Create(AErrCode: Integer; APos: Cardinal);
begin
  ErrCode := AErrCode;
  Pos := APos;
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
{$IFDEF Delphi}
  StSkip = [' ', #10, #13];
{$ENDIF Delphi}
{$IFDEF CBUILDER}
  StSkip = ' '#10#13;
{$ENDIF CBUILDER}
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
          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, #13);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        end
        else
          if (FStyle in [psCpp, psCocoR, psPhp]) and (P[1] = '*') then
          begin
            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 [#10, #13])) }then
        begin
          F := StrScan(P + 1, #13);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        end;
      '''':
        if FStyle = psVB then
        begin
          F := StrScan(P + 1, #13);
          if F = nil then
            F := StrEnd(P + 1);
          P := F;
        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 CharInSet(P[0], 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 CharInSet(P[0], StSkip) do
      Inc(P);
  until F1 = P;
  F := P;
  if FStyle <> psHtml then
  begin
    if CharInSet(P[0], StIdFirstSymbols) then
    { token }
    begin
      while CharInSet(P[0], StIdSymbols) do
        Inc(P);
      SetString(Result, F, P - F);
    end
    else
      if CharInSet(P[0], StConstSymbols10) then
    { number }
      begin
        while CharInSet(P[0], StConstSymbols10) or (P[0] = '.') do
          Inc(P);
        SetString(Result, F, P - F);
      end
      else
        if (Style = psPascal) and (P[0] = '$') and
          CharInSet(P[1], StConstSymbols) then
    { pascal hex number }
        begin
          Inc(P);
          while CharInSet(P[0], StConstSymbols) do
            Inc(P);
          SetString(Result, F, P - F);
        end
        else
          if (Style = psPerl) and (P[0] in ['$', '@', '%', '&']) then
    { perl identifier }
          begin