mysqlparser.pas

MYSQL 连接控件 MYSQL 连接控件

//	Author:			Jacques Venter, [e-mail]
//	Copyright:		1999,2000,2001,2002,2003,2004 SciBit - Scientific Bitware (Pty) Ltd
//	Version:			2004.1.1.0
//	History:       Parser for MySQL statements
//                  2004.3.2.8 (2004-12-19)
//                     Add semicolon as delimiter for macros/params.
//                  2004.1.0.0 (2004-10-21)
//                     Change stop conditions for macros to include EOF, a space, EOL
//						2000.0.1.1
//							First release
//
//   Licensing
//
//       Copyright (c) 1998-2004 SciBit - Scientific Bitware (Pty) Ltd
//       ALL RIGHTS RESERVED
//
//  The entire contents of this file is protected by South African and
//  International Copyright Laws. Unauthorized reproduction,
//  reverse-engineering, and distribution of all or any portion of
//  the code contained in this file is strictly prohibited and may
//  result in severe civil and criminal penalties and will be
//  prosecuted to the maximum extent possible under the law.
//
//  RESTRICTIONS
//
//  THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES
//  (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE
//  SECRETS OF SCIBIT (Pty) Ltd. THE REGISTERED DEVELOPER IS
//  LICENSED TO DISTRIBUTE THE SOURCECODE AND ALL
//  ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY.
//
//  THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED
//  FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE
//  COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE
//  AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT
//  AND PERMISSION FROM SciBit - Scientific Bitware (Pty) Ltd
//
//  CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON
//  ADDITIONAL RESTRICTIONS.
//
//*******************************************************************
unit MySQLParser;
interface
{$I product.inc}
uses
  Classes, SysUtils, Contnrs;
const
{ TBasicParser special tokens }

  tsEOF         = Char(0);
  tsSymbol      = Char(1);
  tsString      = Char(2);
  tsInteger     = Char(3);
  tsFloat       = Char(4);
  tsWString     = Char(5);
  tsHex         = Char(6);
  tsOperator    = Char(7);
  tsComment     = Char(8);  //One Line Comment
  tsCommentML   = Char(9);  //Multi Line Comment
  tsEOL         = Char(10);
  tsCommentMLEnd= Char(11); //Special case where where comment has no starting point
  tsEOS			  = Char(12);
  tsMacro		  = Char(13);
  tsParam       = Char(14);
  tsUndefined   = Char(99);

type
  EBasicParserError = class(Exception);

  TTokenPosition = (tpPrevious, tpCurrent, tpNext);

{== TTokenProps ======================================}
  TTokenProps = class
    TokenPos: integer;
    TokenStr: string;
    TokenType: Char;
  public
    procedure Assign(ATokenProps: TTokenProps);
  end;

{== TBasicParser =====================================}
  TBasicParser = class(TObject)
  private
    FTokenPosition: integer;

    FOrigin:        Longint;
    FBuffer:        PChar;
    FBufPtr:        PChar;
    FSourcePtr:     PChar;
    FSourceEnd:     PChar;
    FTokenPtr:      PChar;
    FStringPtr:     PChar;
    FSourceLine:    Integer;
    FToken:         TTokenProps;
    FFloatType:     Char;
    procedure SkipBlanks(SkipAllBlanks: boolean);
    function GetTokenInRegion(Index: TTokenPosition): TTokenProps;
  protected
    FOperators:     TStringList;
    FHexDelim:      string;
    FStatementDelim:string;
    FOneLineComment:TStringList;
    FCommentStart:  TStringList;
    FCommentEnd:    TStringList;
    FMacroStart: 	TStringList;
    FParamStart: 	TStringList;
    FMacroEnd:		TStringList;

    FRegionTokens:  TObjectList;
  public
    constructor Create(const Script: string);
    destructor Destroy; override;
    procedure Restart(const Script: string);
    procedure CheckToken(T: Char);
    procedure CheckTokenSymbol(const S: string);
    procedure Error(const Ident: string);
    procedure ErrorFmt(const Ident: string; const Args: array of const);
    procedure ErrorStr(const Message: string);
    function NextToken(SkipAllBlanks: boolean): TTokenProps;
    procedure TokenAtPosition(Position: longint);
    function SourcePos: Longint;
    function TokenFloat: Extended;
    function TokenInt: Int64;
    function TokenString: string;
    function TokenSymbolIs(const S: string): Boolean;
    property FloatType: Char read FFloatType;
    property SourceLine: Integer read FSourceLine;
    property SourcePtr: PChar read FSourcePtr;
    property Token: TTokenProps read FToken;

    property RegionTokens[Index: TTokenPosition]: TTokenProps read GetTokenInRegion;

    property HexDelimiter: string read FHexDelim write FHexDelim;
    property OneLineComment: TStringList read FOneLineComment write FOneLineComment;
    property CommentStart: TStringList read FCommentStart write FCommentStart;
    property CommentEnd: TStringList read FCommentEnd write FCommentEnd;
    property ParamStart: TStringList read FParamStart write FParamStart;
    property MacroStart: TStringList read FMacroStart write FMacroStart;
    property MacroEnd: TStringList read FMacroEnd write FMacroEnd;
    property Operators: TStringList read FOperators write FOperators;
    property TokenPosition: Integer read FTokenPosition;
  end;


procedure ParseScript(Script: TStrings; AScript: boolean= False);
function GetScriptType(Script: TStrings): string;

implementation
uses
  MySQLStrUtils;

resourcestring
  SIdentifierExpected = 'Identifier expected';
  SStringExpected = 'String expected';
  SNumberExpected = 'Number expected';
  SCharExpected = '''''%s'''' expected';
  SSymbolExpected = '%s expected';
  SParseError = '%s on line %d';

procedure ParseScript(Script: TStrings; AScript: boolean= False);
var
  FParser: TBasicParser;
  SM: string;
  ts:	TSBStringList;
begin
  if AScript then begin
     SM := Script.Text;
     Script.Clear;
     Script.Add(SM);
  end else begin
     FParser := TBasicParser.Create(Script.Text);
     try
        Script.Clear;
        FParser.Operators.CommaText := '+,-,*,/,=,||,&&,&,<>,|,<<,>>,>,<,~,!,%';
        FParser.HexDelimiter := '0x';
        FParser.OneLineComment.CommaText := '"-- ",#';
        FParser.CommentStart.CommaText := '/*';
        FParser.CommentEnd.CommaText := '*/';
        FParser.MacroStart.CommaText := '[';
        FParser.ParamStart.CommaText := ':';
        FParser.MacroEnd.CommaText := ']';
        ts := TSBStringList.Create;
        ts.StringDel := '';
        with FParser do begin
          while True do begin
            NextToken(False);
            if Token.TokenType in [tsComment,tsCommentML,tsCommentMLEnd] then Continue;
            if SourcePtr[0] in [' ',#9] then
              ts.Add(Token.TokenStr+' ')
            else
              ts.Add(Token.TokenStr);
            if (ts.Count>0) and ((Token.TokenType=tsEOS) or (Token.TokenType=tsEOF)) then begin
              SM := Trim(ts.Text);
              if Length(SM)>0 then Script.Add(SM);
              ts.Clear
            end;
            if Token.TokenType = tsEOF then break
          end
        end;
        ts.Free
     finally
        FreeAndNil(FParser);
     end;
  end;
end;

function GetScriptType(Script: TStrings): string;
var
  FParser: 	TBasicParser;
  ts,qt:    string;
begin
	Result := 'NONE';
  FParser := TBasicParser.Create(Script.Text);
  try
     FParser.Operators.CommaText := '+,-,*,/,=,||,&&,&,<>,|,<<,>>,>,<,~,!,%';
     FParser.HexDelimiter := '0x';
     FParser.OneLineComment.CommaText := '"-- ",#';
     FParser.CommentStart.CommaText := '/*';
     FParser.CommentEnd.CommaText := '*/';
     FParser.MacroStart.CommaText := '[';
     FParser.ParamStart.CommaText := ':';
     FParser.MacroEnd.CommaText := ']';
     with FParser do begin
       while True do begin
         NextToken(False);
         while (Token.TokenType<>tsEOF) and (Token.TokenType<>tsSymbol) do NextToken(false);
           qt := 'NONE';
         if Token.TokenType = tsSymbol then begin
           ts := UpperCase(TokenString);
           if ts = 'SELECT'  then qt := ts;
           if ts = 'DELETE'  then qt := ts;
           if ts = 'INSERT'  then qt := ts;
           if ts = 'REPLACE' then qt := ts;
           if ts = 'LOAD'    then qt := ts;
           if ts = 'UPDATE'  then qt := ts;
           if ts = 'SET'     then qt := 'SCRIPT';
           if ts = 'CREATE'  then qt := 'SCRIPT';
           if ts = 'DROP'    then qt := 'SCRIPT';
           if (Result <> 'NONE') then begin
             Result := 'SCRIPT';
             exit;
           end;
           Result := qt;
         end;
         while (Token.TokenType<>tsEOF) and (Token.TokenType<>tsEOS) do NextToken(false);
         if Token.TokenType = tsEOF then break;
       end
     end;
  finally
  	FreeAndNil(FParser);
  end;
end;

{== TTokenProps ======================================}
{-----------------------------------------------------}

procedure TTokenProps.Assign(ATokenProps: TTokenProps);
begin
  TokenPos := ATokenProps.TokenPos;
  TokenStr := ATokenProps.TokenStr;
  TokenType := ATokenProps.TokenType
end;

{== TBasicParser =====================================}
{-----------------------------------------------------}

constructor TBasicParser.Create;
begin
  FBuffer := PChar(Script);

  FOperators := TStringList.Create;
  FOneLineComment := TStringList.Create;
  FCommentStart := TStringList.Create;
  FCommentEnd := TStringList.Create;
  FMacroStart := TStringList.Create;
  FParamStart := TStringList.Create;
  FMacroEnd := TStringList.Create;

  FToken := TTokenProps.Create;
  FRegionTokens := TObjectList.Create(true);
  FRegionTokens.Add(TTokenProps.Create);
  FRegionTokens.Add(TTokenProps.Create);
  FRegionTokens.Add(TTokenProps.Create);
  FStatementDelim := ';';
  Restart(Script)
end;

{-----------------------------------------------------}

destructor TBasicParser.Destroy;
begin
  FOperators.Free;
  FOneLineComment.Free;
  FCommentStart.Free;
  FCommentEnd.Free;
  FRegionTokens.Free;
  FMacroStart.Free;
  FParamStart.Free;
  FMacroEnd.Free;
  FToken.Free;
end;

{-----------------------------------------------------}

procedure TBasicParser.Restart;
begin
  FBuffer := PChar(Script);
  FBufPtr := FBuffer;
  FSourcePtr := FBuffer;
  FSourceEnd := FBuffer;
  FTokenPtr := FBuffer;
  FSourceLine := 0;
  FOrigin := 0;
  FToken.TokenPos := 0;
  FToken.TokenStr := '';
  FToken.TokenType := tsUndefined;
end;

{-----------------------------------------------------}

function TBasicParser.GetTokenInRegion(Index: TTokenPosition): TTokenProps;
begin
  Result := TTokenProps(FRegionTokens.Items[Ord(Index)]);
end;

{-----------------------------------------------------}

procedure TBasicParser.CheckToken(T: Char);
begin
  if Token.TokenType <> T then
    case T of
      tsSymbol:
        Error(SIdentifierExpected);
      tsString, tsWString:
        Error(SStringExpected);
      tsInteger, tsFloat:
        Error(SNumberExpected);
    else
      ErrorFmt(SCharExpected, [T]);
    end;
end;

{-----------------------------------------------------}

procedure TBasicParser.CheckTokenSymbol(const S: string);
begin
  if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]);
end;

{-----------------------------------------------------}

procedure TBasicParser.Error(const Ident: string);
begin
  ErrorStr(Ident);
end;

{-----------------------------------------------------}

procedure TBasicParser.ErrorFmt(const Ident: string; const Args: array of const);
begin