abslexer.pas

Absolute Database 是来替代BDE[Borland数据库引擎]的用于Delphi 和 C++ Builder 开发用的数据库引擎. 它小巧, 高速, 健壮, 易于使用. 它能直接编译进

unit ABSLexer;

{$I ABSVer.inc}

interface

uses classes, windows, sysutils, db,
{$IFDEF DEBUG_LOG}
 ABSDebug,
{$ENDIF}
 ABSVariant,
 ABSExcept,
 ABSConst;



const Lf: string = #$0A;       // binary mode line separator
const Cr: string = #$0D;       // text mode line separator
const Crlf: string = #$0D#$0A; // text mode line separator
const Tab: string = #$09; // <tab>
const Comment = '-'; // -- comment <Crlf>
const Comment1 = '#'; // # comment <Crlf>
const Dot = '.';
const Comma = ',';
const SemiColon = ';';
const Asterisk = '*';
const SingleQuote = '''';
const BackQuote = '`';
const DoubleQuote = '"';
const Space = ' ';
const LeftParenthesis = '(';
const RightParenthesis = ')';
const LeftSquareBracket = '[';
const RightSquareBracket = ']';
const Percent = '%';
const BackSlash = '\';

EABSTokenType: array [0..11] of string =
(
 'tktNone', 'tktString', 'tktQuotedString', 'tktBracketedString',
 'tktInt', 'tktFloat', 'tktReservedWord',
 'tktParameter', 'tktLeftParenthesis', 'tktRightParenthesis',
 'tktComma', 'tktDot'
);

type
 TTokenType = (tktNone, tktString, tktQuotedString, tktBracketedString,
 tktInt, tktFloat, tktReservedWord,
 tktParameter, tktLeftParenthesis, tktRightParenthesis,
 tktComma, tktDot);

 TTokenTypes = set of TTokenType;

 TToken = record
  TokenType:      TTokenType;
  ReservedWord:   TReservedWord;
  Text:           String;
  ParamValue:     TABSVariant;
  LineNum:        Integer; // number of line in script where token begins
  ColumnNum:      Integer; // number of column in script where token begins
 end;

 PToken = ^TToken;

 TSQLCommand = record
  Tokens:     array of TToken;
  NumTokens:  Integer;
  CurrentTokenNo: Integer;
 end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSSQLParam
//
////////////////////////////////////////////////////////////////////////////////

  TABSSQLParam = class (TABSVariant)
   public
    Name:  String;
  end;


////////////////////////////////////////////////////////////////////////////////
//
// TABSSQLParams
//
////////////////////////////////////////////////////////////////////////////////
            
  TABSSQLParams = class (TObject)
   private
    FParamList: TList;
   private
    function GetCount: Integer;
    function GetValue(Index: Integer): TABSSQLParam;
    procedure SetValue(Index: Integer; Value: TABSSQLParam);
   public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function AddCreated: TABSSQLParam;
    function GetParamByName(Name: String): TABSSQLParam;
   public
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TABSSQLParam read GetValue write SetValue; default;
  end;//TABSSQLParams




 TABSLexer = class (TObject)
  private
   FSQL:              String;
   FSQLParams:        TABSSQLParams;
  private
   procedure Parse;
  public
   NumCommands:       Integer;
   Commands:          array of TSQLCommand;
   CurrentCommandNo:  Integer;

   constructor Create(SQLScript: string; SQLParams: TABSSQLParams = nil);
   destructor Destroy; override;
   function Test(bGenerate: Boolean = true; bShowDetails: Boolean = true): string;
   procedure AddCommand;
   procedure AddToken(Token: TToken);

   // makes next command current
   function GetNextCommand: Boolean;
   // gets next token in current command
   function GetNextToken(var Token: TToken): Boolean;
   // gets current token in current command
   function GetCurrentToken(var Token: TToken): Boolean;
   // looks at next token
   function LookNextToken(var Token: TToken): Boolean;
   // gets current token No
   function GetCurrentTokenNo: integer;
   // sets current token No
   function SetCurrentTokenNo(TokenNo: integer; var Token: TToken): Boolean; overload;
   function SetCurrentTokenNo(TokenNo: integer): Boolean; overload;
   // gets first next token specified type
   function GetNextSpecifiedToken(var Token: TToken; TokenTypes: TTokenTypes): Boolean;
 end;

 // checks whether token is reserved word
 function IsReservedWord(Token: TToken; ReservedWord: TReservedWord=rwNone): Boolean;
 function FindReservedWord(s: string): Integer;


implementation

uses ABSTypes;

////////////////////////////////////////////////////////////////////////////////
//
// TABSSQLParams
//
////////////////////////////////////////////////////////////////////////////////


//------------------------------------------------------------------------------
// Constructor
//------------------------------------------------------------------------------
constructor TABSSQLParams.Create;
begin
  FParamList := TList.Create;
end;//Create


//------------------------------------------------------------------------------
// Destructor
//------------------------------------------------------------------------------
destructor TABSSQLParams.Destroy;
begin
  Clear;
  FParamList.Free;
end;//Destroy


//------------------------------------------------------------------------------
// return Count
//------------------------------------------------------------------------------
function TABSSQLParams.GetCount: Integer;
begin
  Result := FParamList.Count;
end;//GetCount


//------------------------------------------------------------------------------
// GetValue
//------------------------------------------------------------------------------
function TABSSQLParams.GetValue(Index: Integer): TABSSQLParam;
begin
  Result := TABSSQLParam(FParamList[Index]);
end;//GetValue


//------------------------------------------------------------------------------
// SetValue
//------------------------------------------------------------------------------
procedure TABSSQLParams.SetValue(Index: Integer; Value: TABSSQLParam);
begin
  TABSSQLParam(FParamList[Index]).Free;
  FParamList[Index] := Value;
end;//SetValue


//------------------------------------------------------------------------------
// AddCreated
//------------------------------------------------------------------------------
function TABSSQLParams.AddCreated: TABSSQLParam;
begin
  Result := TABSSQLParam.Create;
  FParamList.Add(Result);
end;//AddCreated


//------------------------------------------------------------------------------
// Clear
//------------------------------------------------------------------------------
procedure TABSSQLParams.Clear;
var i: Integer;
begin
  for i:=0 to Count-1 do
    TABSSQLParam(FParamList[i]).Free;
  FParamList.Clear;
end;//Clear


//------------------------------------------------------------------------------
// GetParamByName
//------------------------------------------------------------------------------
function TABSSQLParams.GetParamByName(Name: String): TABSSQLParam;
var i: Integer;
begin
  Result := nil;
  for i:=0 to Count-1 do
   if (AnsiUpperCase(items[i].Name) = AnsiUpperCase(Name)) then
    begin
     Result := items[i];
     Break;
    end;
end;//GetParamByName




////////////////////////////////////////////////////////////////////////////////
//
// TABSLexer
//
////////////////////////////////////////////////////////////////////////////////


//------------------------------------------------------------------------------
// Parse SQL script
//------------------------------------------------------------------------------
procedure TABSLexer.Parse;
var i,l:      Integer;
    line,command,token,column:  Integer;
    c,priorSymbol:   char;
    numParenthesis,
    LeftParenthesisLine,
    LeftParenthesisColumn,
    RightParenthesisLine,
    RightParenthesisColumn,
    quoteLine,quoteColumn: Integer;
    bIsDelimiter:     boolean;
    bTokenStarted:    boolean;
    bCommandStarted:  boolean;
    bNewTokenStarted: boolean;
    bTokenFinished:   boolean;
    bQuoteNotClosed:  boolean;
    LastParamNo: Integer;

  function GetNextSymbol: char;
  begin
   result := ' ';
    if (i < l-1) then
     result := pChar(pChar(FSQL)+i+1)^;
  end;


 function IsNewTokenStarted: Boolean;
 begin
  result := false;
  if (bTokenStarted) then
   begin
      if (c = '>') or (c = '<') or (c = '=') or (c = '(') or (c = ')') or
         (c = ',') or (c = '/') or (c = '*') or (c = ':') or (c = '?') or (c = '|') or
         ((c=Dot) and (Commands[command].Tokens[token].TokenType<>tktInt)) then
           result := true
      else
      if (Commands[command].Tokens[token].TokenType = tktDot) then
       begin
         if not ((c >= '0') and (c <= '9')) and (c <> space) then
          result := true;
       end
      else
      if (Commands[command].Tokens[token].TokenType = tktString) then
       begin
        if (c = '+') or (c = '-') then
         result := true;
       end
      else
      if (Commands[command].Tokens[token].TokenType = tktInt) then
       begin
        if (c = '+') and (UpperCase(priorSymbol) <> 'E') then
         result := true
        else
        if (c = '-') and (UpperCase(priorSymbol) <> 'E') then
         result := true;
       end; // Int or Float token
   end // some token already started
  else
   begin
    if (not bIsDelimiter) then
     result := true;
   end; // no token started
 end; // IsNewTokenStarted

 function IsTokenFinished: Boolean;
 begin
  result := false;
  if (bTokenStarted) then
   begin
    if (bIsDelimiter) then
     result := true;
   end;
 end; // IsTokenFinished

 procedure CreateCommand;
 begin
  inc(NumCommands);
  SetLength(Commands, NumCommands);
  command := NumCommands-1;
  Commands[command].NumTokens := 0;
  Commands[command].Tokens := nil;
  token := 0;
  bCommandStarted := true;
  numParenthesis := 0;
 end; // CreateCommand;

 procedure CloseToken;
 var i:         Integer;
     Param:     TABSSQLParam;
     ParamName: String;
//     oldSeparator: char;
 begin
  if (not bTokenStarted) then
   Exit;
  // check int or float
  if (Commands[command].Tokens[token].TokenType = tktInt) then
   begin
    // check int or float
    if (Pos('.',Commands[command].Tokens[token].Text) > 0) then
     Commands[command].Tokens[token].TokenType := tktFloat
    else
    if (Pos('E',UpperCase(Commands[command].Tokens[token].Text)) > 0) then
     Commands[command].Tokens[token].TokenType := tktFloat;
   end;
  // String 
  if (Commands[command].Tokens[token].TokenType = tktString) then
   begin
    // check for SQLParameter ( :name)
    if (Commands[command].Tokens[token].Text[1] in [':', '?'] ) then
     begin
      Commands[command].Tokens[token].TokenType := tktParameter;
      if (Commands[command].Tokens[token].Text[1] = ':') then
       begin
        // param name without ':'
        ParamName := Copy(Commands[command].Tokens[token].Text, 2,
                         Length(Commands[command].Tokens[token].Text)-1);
        Commands[command].Tokens[token].Text := ParamName;
        // try to set param value
        if Assigned(FSQLParams) then
          Param := FSQLParams.GetParamByName(ParamName);
       end
      else
       begin
        Param := FSQLParams[LastParamNo];
        Inc(LastParamNo);
        ParamName := 'Param' + IntToStr(LastParamNo);
        Commands[command].Tokens[token].Text := ParamName;
       end;

      if (Param <> nil) then
        begin
          // commented in 5.02 (to support NULL params of unknown type)
//          if (Param.DataType = bftUnknown) then
//            raise EABSException.Create(20271, ErrorAParameterOfUnknownType, [Param.Name]);
          Commands[command].Tokens[token].ParamValue := TABSVariant.Create;
          Commands[command].Tokens[token].ParamValue.Assign(Param);
        end
      else
        raise EABSException.Create(30358, ErrorGParameterValueNotFound, [ParamName]);
     end
    else
     begin
      // check for reserved word
      i := FindReservedWord(Commands[command].Tokens[token].Text);
      if (i > 0) then
       begin
        Commands[command].Tokens[token].ReservedWord := TReservedWord(i);
        Commands[command].Tokens[token].TokenType := tktReservedWord;
       end;
     end;
   end;// if String
  bTokenStarted := false;
 end; // CloseToken;

 procedure CreateToken;
 var NextSymbol: char;
     quoteSymbol: char;
 begin
  if (not bCommandStarted) then
   CreateCommand;
  bTokenStarted := true;
  inc(Commands[command].NumTokens);
  SetLength(Commands[command].Tokens,Commands[command].NumTokens);

  token := Commands[command].NumTokens - 1;
  Commands[command].Tokens[token].Text := c;
  Commands[command].Tokens[token].ColumnNum := column;
  Commands[command].Tokens[token].LineNum := line;
  Commands[command].Tokens[token].ReservedWord := rwNone;
  Commands[command].Tokens[token].ParamValue := nil;

  NextSymbol := GetNextSymbol;
  // here will be scanning quoted string to its end
  if (c = SingleQuote) or (c = BackQuote) or (c = DoubleQuote) or (c = LeftSquareBracket) or
     ((c=':') and (NextSymbol in [SingleQuote, DoubleQuote, LeftSquareBracket]))then
   begin
    Commands[command].Tokens[token].Text := '';
    case c of
      SingleQuote, DoubleQuote:
         Commands[command].Tokens[token].TokenType := tktQuotedString;
      BackQuote:
         Commands[command].Tokens[token].TokenType := tktString;
      LeftSquareBracket:
         Commands[command].Tokens[token].TokenType := tktBracketedString;
      ':':
         Commands[command].Tokens[token].TokenType := tktString;
    end;
    if (c = ':') then
      begin
        Commands[command].Tokens[token].Text := ':';
        if (NextSymbol <> LeftSquareBracket) then
         quoteSymbol := NextSymbol
        else
         quoteSymbol := RightSquareBracket;
        inc(i);
      end
    else
      if (c <> LeftSquareBracket) then
       quoteSymbol := c
      else
       quoteSymbol := RightSquareBracket;
    quoteLine := line;
    quoteColumn := column;
    bQuoteNotClosed := true;
    inc(i);
    while (i < l) do
     begin
      c := pChar(pChar(FSQL)+i)^;
      if ((quoteSymbol in [BackQuote]) and (c = BackSlash)) then
       begin
        Inc(i);
        if (not (i < l)) then
          Break;
        c := pChar(pChar(FSQL)+i)^;
       end;
      NextSymbol := GetNextSymbol;
      if (c = quoteSymbol) then
       begin
        if (NextSymbol = c) then
         begin
          Commands[command].Tokens[token].Text :=
            Commands[command].Tokens[token].Text + c;
          inc(i,2);
          inc(column,2);
          continue;
         end // ''
        else
         begin
          // end of QuotedStr
          bQuoteNotClosed := false;