zsqlscanner.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{               Lexical Sql-Scanner class                }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZSqlScanner;

interface

uses Classes, SysUtils, ZScanner, ZSqlTypes;

type
  { Abstract Sql-scanner class definition }
  TZSqlScanner = class (TZScanner)
  protected
    FDatabaseType: TDatabaseType;

    function LowRunLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;

    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function InnerProcSqlIdent(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function InnerProcSqlDelim(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
  public
    constructor Create; override;

    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;

    function ExtractSpaces: string;
    function ExtractStatement(var CurrPos, CurrLen, CurrLineNo: Integer): string;

    property DatabaseType: TDatabaseType read FDatabaseType;
  end;

  { Interbase Scanner }
  TZIbSqlScanner = class (TZSqlScanner)
  public
    constructor Create; override;
  end;

  { MS SQL Scanner }
  TZMsSqlScanner = class (TZSqlScanner)
  protected
    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    constructor Create; override;
  end;

  { Oracle Scanner }
  TZOraSqlScanner = class (TZSqlScanner)
  public
    constructor Create; override;
  end;

  { PostgreSql Scanner }
  TZPgSqlScanner = class (TZSqlScanner)
  protected
    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
    function InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    constructor Create; override;
    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;
  end;

  { MySql Scanner }
  TZMySqlScanner = class (TZSqlScanner)
  protected
    function InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
    function InnerProcSqlString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    constructor Create; override;
    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;
  end;

{ Create a Sql scanner according DatabaseType }
function CreateSqlScanner(DatabaseType: TDatabaseType): TZSqlScanner;

implementation

{*********************** General constants ************************}
const
  MaxSqlKeyword  = 24;
  SqlKeyword: array[1..MaxSqlKeyword] of string =
  (
    'select','update','delete','create','drop','explain','from','where',
    'order','by','group','having','set','values','into','union','all',
    'distinct','left','right','on','join','outer','inner'
  );

{***********************  General routines ***********************}
{ Create a Sql scanner according DatabaseType }
function CreateSqlScanner(DatabaseType: TDatabaseType): TZSqlScanner;
begin
  case DatabaseType of
    dtMySql:      Result := TZMySqlScanner.Create;
    dtInterbase:  Result := TZIbSqlScanner.Create;
    dtMsSql:      Result := TZMsSqlScanner.Create;
    dtPostgreSql: Result := TZPgSqlScanner.Create;
    dtOracle:     Result := TZOraSqlScanner.Create;
    else          Result := TZMySqlScanner.Create;
  end;
end;

{ TZSqlScanner }

{ Class constructor }
constructor TZSqlScanner.Create;
begin
  inherited Create;
  FDatabaseType := dtUnknown;
end;

{ Unconvert value into pascal-like strings }
function TZSqlScanner.UnwrapString(Value: string): string;
var
  Pos, Len: Integer;
begin
  Result := '';
  if Value = '' then Exit;
  Pos := 1;
  Delete(Value, 1, 1);
  Len := Length(Value);
  while Pos <= Len do
  begin
    if not (Value[Pos] in ['''', '"']) then
      Result := Result + Value[Pos]
    else if (Pos < Len) and (Value[Pos+1] = Value[Pos]) then
    begin
      Result := Result + Value[Pos];
      Inc(Pos);
    end;
    Inc(Pos);
  end;
end;

{ Convert string value into pascal-like string }
function TZSqlScanner.WrapString(Value: string): string;
var
  Pos: Integer;
begin
  Result := '''';
  for Pos := 1 to Length(Value) do
  begin
    Result := Result + Value[Pos];
    if Value[Pos] = '''' then
      Result := Result + Value[Pos];
  end;
  Result := Result + '''';
end;

{ Get lowlevel token }
function TZSqlScanner.LowRunLex(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  { Initialize the lexing }
  Result := InnerStartLex(CurrPos, CurrLineNo, CurrToken);

  if Result <> tokUnknown then Exit;

  { Process sql comments }
  Result := InnerProcSqlComment(CurrPos, CurrLineNo, CurrToken);
  if Result <> tokUnknown then Exit;

  { Look for sql delimiters }
  Result := InnerProcSqlDelim(CurrPos, CurrLineNo, CurrToken);
  if Result <> tokUnknown then Exit;

  { Look for sql string }
  Result := InnerProcSqlString(CurrPos, CurrLineNo, CurrToken);
  if Result <> tokUnknown then Exit;

  { Look for identifiers and constants }
  Result := InnerProcSqlIdent(CurrPos, CurrLineNo, CurrToken);
end;

{ Extract leading whitespaces }
function TZSqlScanner.ExtractSpaces: string;
begin
  Result := '';
  if FBufferPos > FBufferLen then Exit;
  { Skip whitespaces }
  while (FBuffer[FBufferPos] in [' ',#9,#10])
    and (FBufferPos <= FBufferLen) do
  begin
    Result := Result + FBuffer[FBufferPos];
    Inc(FBufferPos);
  end;
end;

{ Extract an Sql statement }
function TZSqlScanner.ExtractStatement(var CurrPos, CurrLen,
  CurrLineNo: Integer): string;
var
  Token: string;
  TokenType, TokenLineNo, TokenPos: Integer;
begin
  ExtractSpaces;
  CurrPos := FBufferPos; // Added
  CurrLineNo := FBufferLine;
  Result := '';
  TokenType := RunLex(TokenPos, TokenLineNo, Token);
  while TokenType in [tokEol, tokLF] do
    TokenType := RunLex(TokenPos, TokenLineNo, Token);
//  CurrPos := TokenPos - 1;
  while (TokenType <> tokEof) and (Token <> ';') do
  begin
    { Handling LF chars  (#10) }
    if (TokenType=tokLF) and not (Result[Length(Result)] in [' ', #9]) then
      Result := Result + ' '
    else
      Result := Result + Token;
    Token := ExtractSpaces;
    if Token <> '' then
      Result := Result + ' ';
    TokenType := RunLex(TokenPos, TokenLineNo, Token);
  end;
  CurrLen := FBufferPos - CurrPos; // -1;
  if ShowComment and ShowEol then
    Result := AdjustLineBreaks(Result);
end;

{********************** Lexical procedures *********************}

{ Process sql delimiters }
function TZSqlScanner.InnerProcSqlDelim(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp, Temp1: Char;
begin
  Result := tokUnknown;
  Temp := CurrToken[1];
  { Check for brace }
  if Temp in ['{', '}', '(', ')', '[', ']'] then
  begin
    Result := tokBrace;
  end
  { Check for separator }
  else if Temp in [',', ';', ':'] then
  begin
    Result := tokSeparator;
  end
  { Check for delimiters }
  else if Pos(Temp, '~!#%?|=+-<>/*^@#') > 0 then
  begin
    Result := tokOperator;
    if FBufferPos <= FBufferLen then
      Temp1 := FBuffer[FBufferPos]
    else Temp1 := #0;
    if ((Temp = '>') and (Temp1 = '='))
      or ((Temp = '<') and (Temp1 in ['=', '>'])) then
    begin
      CurrToken := CurrToken + Temp1;
      Inc(FBufferPos);
    end;
  end;
end;

{ Process sql comments }
function TZSqlScanner.InnerProcSqlComment(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  { Check for single-line comment }
  if (CurrToken[1] = '/') and (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] = '/') then
  begin
    Result := InnerProcLineComment(CurrPos, CurrLineNo, CurrToken);
    Exit;