{*******************************************************}
{                                                       }
{       Parsers.pas                                     }
{                                                       }
{                                                       }
{       Copyright (c) 2004-2008 Shenturk                }
{       Create: 10.02.2004                              }
{       Update: 14.05.2008                              }
{                                                       }
{                                                       }
{*******************************************************}

unit Parsers;

interface

uses SysUtils, Classes;

const
  idUnknown         = $FFFF;
  idEOF             = 0;
  idSymbol          = 1;
  idString          = 2;
  idInteger         = 3;
  idFloat           = 4;
  idIdent           = 5;  // Same as idSymbol
  idComment         = 6;  // All comment types
  idHtml            = 7;
  idLessThan        = 8;  // <
  idScriptBegin     = 9;  // <%
  idScriptEnd       = 10; // %>
  idPercent         = 11; // %
  idSlash           = 12; // /
  idLBrace          = 13; // {
  idRBrace          = 14; // }
  idGreaterThan     = 15; // >
  idNullHtml        = 16; //
  idEqual           = 17; // =
  idNotEqual        = 18; // <>
  idAssignment      = 19; // :=
  idSemicolon       = 20; // ;
  idColon           = 21; // :
  idComma           = 22; // ,
  idPlus            = 23; // +
  idMinus           = 24; // -
  idMul             = 25; // *
  idDiv             = 26; // /
  idLessEqual       = 27; // <=
  idGreaterEqual    = 28; // >=
  idLanguage        = 29; // <%@
  idDirective       = idLanguage;
  idLParenthes      = 30; // (
  idRParenthes      = 31; // )
  idAt              = 32; // @
  idLeftBracket     = 33; // [
  idRightBracket    = 34; // ]
  idLeftBrace       = 35; // {
  idRightBrace      = 36; // }
  idTilde           = 37; // ~
  idExclamation     = 38; // !
  idDot             = 39; // .
  idTwoDots         = 40; // ..
  idEvaluate        = 41; // <%=
  idDocumentType    = 42; // <!
  idCommentBegin    = 43; // <!--
  idCommentEnd      = 44; // -->
  idSharp           = 45; // #

type
  { EScriptParserError }
  EScriptParserError = class(Exception);

  { TScriptParser }
  TScriptParser = class(TObject)
  private
    FStream: TStream;
    FBuffer: PChar;
    FLastPtr: PChar;
    FTokenPtr: PChar;
    FToken: Word;
    FLine: LongInt;
    FHtml: Boolean;
    FComment: Boolean;
    FString: string;
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    function NextToken: Word;
    function TokenString: string;
    function TokenFloat: Extended;
    function TokenInt: Longint;
    procedure SkipBlanks;
    function SkipHtmlCode: Word;
    function SourcePos: LongInt;
    function NextChar: Char;
    procedure Error(const Ident: string);
    procedure ErrorFmt(const Ident: string; Args: array of const);
    procedure ErrorStr(const Message: string);
    function GetPureText(StartPtr, EndPtr: PChar): string;
    property Token: Word read FToken;
    property Line: LongInt read FLine;
    property LastPtr: PChar read FLastPtr;
  end;

{ GetQuotedStr }
function GetQuotedStr(const S: string): string;

implementation

const
  SParseError = 'Parse Error: %s, (%d)';

{ GetQuotedStr }
function GetQuotedStr(const S: string): string;
var
  I: Integer;
begin
  Result := S;
  for I := Length(Result) downto 1 do
    if Result[I] = '"' then Insert('"', Result, I);
  Result := '"' + Result + '"';
end;

{ VarTypeToId }
function VarTypeToId(VarType: Integer): Word;
begin
  case VarType of
    varByte,
    varInteger,
    varSmallInt: Result := idInteger;
    varSingle,
    varDouble: Result := idFloat;
    varString: Result := idString;
  else Result := idUnknown;
  end;
end;

{ TScriptParser }

constructor TScriptParser.Create(Stream: TStream);
var
  C: Char;
begin
  FStream := Stream;
  FBuffer := AllocMem(FStream.Size + 1);
  FStream.Seek(0, soFromBeginning);
  FStream.Read(C, SizeOf(C));
  if C = #$EF then FStream.Seek(3, soFromBeginning)
  else FStream.Seek(0, soFromBeginning);
  FStream.Read(FBuffer^, FStream.Size);
  FLastPtr := FBuffer;
  FTokenPtr := FBuffer;
  FLine := 1;
  FHtml := True;
  FComment := False;
end;

destructor TScriptParser.Destroy;
begin
  FreeMem(FBuffer, FStream.Size + 1);
  inherited Destroy;
end;

function TScriptParser.NextToken: Word;
var
  P: PChar;
begin

  if FHtml then
  begin
    FTokenPtr := FLastPtr;
    Result := SkipHtmlCode;
    if FTokenPtr = FLastPtr then Result := idNullHtml;
    FToken := Result;
    Exit;
  end;

  SkipBlanks;
  P := FLastPtr;
  FTokenPtr := P;

  case P^ of
    #0 : Result := idEOF;
    '<':
      begin
        Result := idLessThan;
        Inc(P);
        if P^ = '%' then
        begin
          Inc(P);
          FHtml := False;
          Result := idScriptBegin;
          case P^ of
            '@':
              begin
                Inc(P);
                Result := idDirective;
              end;
            '=':
              begin
                Inc(P);
                Result := idEvaluate;
              end;
          end;
        end;
      end;
    '%':
      begin
        Result := idPercent;
        Inc(P);
        if P^ = '>' then
        begin
          Inc(P);
          Result := idScriptEnd;
          FHtml := True;
        end;
      end;
  else
    Result := idUnknown;
    if P^ <> #0 then Inc(P);
  end;
  FLastPtr := P;
  FToken := Result;
end;

function TScriptParser.TokenString: string;
begin
  if FToken = idString then Result := FString
  else SetString(Result, FTokenPtr, FLastPtr - FTokenPtr);
end;

function TScriptParser.TokenFloat: Extended;
begin
  Result := StrToFloat(TokenString);
end;

function TScriptParser.TokenInt: Longint;
begin
  Result := StrToInt(TokenString);
end;

procedure TScriptParser.SkipBlanks;
begin
  while True do
  begin
    case FLastPtr^ of
      #0, #33..#255: Exit;
      #10: Inc(FLine);
    end;
    Inc(FLastPtr);
  end;
end;

function TScriptParser.SkipHtmlCode: Word;
begin
  Result := idHtml;
  while True do
  begin
    case FLastPtr^ of
      #0:
        begin
          FHtml := False;
          Exit;
        end;
      #10: Inc(FLine);
      '<':
        begin
          Inc(FLastPtr);
          case FLastPtr^ of
            '%':
              begin
                Dec(FLastPtr);
                FHtml := False;
                Exit;
              end;
          end;
        end;
    end;
    if FLastPtr^ <> #0 then Inc(FLastPtr); { Bug fixed }
  end;
end;

function TScriptParser.SourcePos: LongInt;
begin
  Result := FLastPtr - FBuffer;
end;

function TScriptParser.NextChar: Char;
var
  P: PChar;
begin
  P := FLastPtr;
  Inc(P);
  Result := P^;
end;

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

procedure TScriptParser.ErrorFmt(const Ident: string; Args: array of const);
begin
  ErrorStr(Format(Ident, Args));
end;

procedure TScriptParser.ErrorStr(const Message: string);
begin
  raise EScriptParserError.CreateFmt(SParseError, [Message, FLine]);
end;

function TScriptParser.GetPureText(StartPtr, EndPtr: PChar): string;
begin
  SetString(Result, StartPtr, EndPtr - StartPtr);
end;

end.