1211 lines
30 KiB
ObjectPascal
1211 lines
30 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
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 <a dott prygounkov att gmx dott de>
|
|
Copyright (c) 1999, 2002 Andrei Prygounkov
|
|
All Rights Reserved.
|
|
|
|
Contributor(s): Eswar Prakash R [eswar dott prakash att gmail.com]
|
|
|
|
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]
|
|
|
|
-----------------------------------------------------------------------------}
|
|
// $Id: JvHLParser.pas 10612 2006-05-19 19:04:09Z jfudickar $
|
|
|
|
{history:
|
|
3.0:
|
|
2003-09-20: (changes by Andreas Hausladen)
|
|
- added a TJvIParserW parser for unicode text
|
|
- added unicode versions of the functions
|
|
}
|
|
|
|
unit JvHLParser;
|
|
|
|
{$I jvcl.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
SysUtils, Classes, Dialogs,
|
|
JclWideStrings,
|
|
JvTypes, JvJCLUtils;
|
|
|
|
const
|
|
ieBadRemark = 1;
|
|
|
|
type
|
|
TIParserStyle = (psNone, psPascal, psCpp, psPython, psVB, psHtml, psPerl, psCocoR, psPhp, psSql);
|
|
|
|
TJvIParser = class(TObject)
|
|
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;
|
|
|
|
TJvIParserW = class(TObject)
|
|
protected
|
|
FpcProgram: PWideChar;
|
|
FpcPos: PWideChar; // Current position [translated]
|
|
FHistory: TWStrings;
|
|
FHistorySize: Integer;
|
|
FHistoryPtr: Integer;
|
|
FStyle: TIParserStyle;
|
|
FReturnComments: Boolean;
|
|
function HistoryInd(Index: Integer): Integer;
|
|
function GetHistory(Index: Integer): WideString;
|
|
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: WideString;
|
|
{ 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]: WideString 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: PWideChar read FpcPos write FpcPos;
|
|
property pcProgram: PWideChar read FpcProgram write FpcProgram;
|
|
property Style: TIParserStyle read FStyle write FStyle;
|
|
property ReturnComments: Boolean read FReturnComments write FReturnComments;
|
|
end;
|
|
|
|
EJvIParserError = class(Exception)
|
|
private
|
|
FErrCode: Integer;
|
|
FPosition: Cardinal;
|
|
public
|
|
constructor Create(AErrCode: Integer; APosition: Cardinal; Dummy: Integer = 0);
|
|
property ErrCode: Integer read FErrCode;
|
|
property Position: Cardinal read FPosition;
|
|
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);
|
|
|
|
function IsStringConstantW(const St: WideString): Boolean;
|
|
function IsIntConstantW(const St: WideString): Boolean;
|
|
function IsRealConstantW(const St: WideString): Boolean;
|
|
function IsIdentifierW(const ID: WideString): Boolean;
|
|
function GetStringValueW(const St: WideString): WideString;
|
|
procedure ParseStringW(const S: WideString; Ss: TWStrings);
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
const
|
|
UnitVersioning: TUnitVersionInfo = (
|
|
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvHLParser.pas $';
|
|
Revision: '$Revision: 10612 $';
|
|
Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $';
|
|
LogPath: 'JVCL\run'
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
JvConsts;
|
|
|
|
//=== { EJvIParserError } ====================================================
|
|
|
|
constructor EJvIParserError.Create(AErrCode: Integer; APosition: Cardinal; Dummy: Integer = 0);
|
|
begin
|
|
inherited Create('');
|
|
FErrCode := AErrCode;
|
|
FPosition := APosition;
|
|
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
|
|
StSkip = [' ', Lf, Cr];
|
|
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
|
|
if P[2] = #0 then
|
|
Exit; // line end
|
|
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, Cr);
|
|
if F = nil then
|
|
F := StrEnd(P + 1);
|
|
P := F;
|
|
end
|
|
else
|
|
if (FStyle in [psCpp, psCocoR, psPhp, psSQL]) and (P[1] = '*') then
|
|
begin
|
|
if P[2] = #0 then
|
|
Exit; // line end
|
|
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 [Lf, Cr])) }then
|
|
begin
|
|
F := StrScan(P + 1, Cr);
|
|
if F = nil then
|
|
F := StrEnd(P + 1);
|
|
P := F;
|
|
end;
|
|
'''':
|
|
if FStyle = psVB then
|
|
begin
|
|
F := StrScan(P + 1, Cr);
|
|
if F = nil then
|
|
F := StrEnd(P + 1);
|
|
P := F;
|
|
end;
|
|
// Support for the SQL -- comments
|
|
'-':
|
|
if (FStyle = psSql) and (P[1] = '-') then
|
|
begin
|
|
F := StrScan(P + 1, Cr);
|
|
if F = nil then
|
|
F := StrEnd(P + 1);
|
|
P := F;
|
|
end;
|
|
// Support for multiline comments for HTML
|
|
'<':
|
|
if (FStyle = psHtml) and (P[1] = '!') then
|
|
begin
|
|
// we need the next 2 chars to be --
|
|
if (P[2] = #0) or (P[3] = #0) then
|
|
Exit; // line end
|
|
if (P[2] <> '-') and (P[3] <> '-') then
|
|
Exit;
|
|
F := P + 3;
|
|
while True do
|
|
begin
|
|
F := StrScan(F, '-');
|
|
if F = nil then //IParserError(ieBadRemark, P - FpcProgram);
|
|
Exit;
|
|
if (F[1] = '-') and (F[2] = '>') then
|
|
begin
|
|
Inc(F, 2);
|
|
Break;
|
|
end;
|
|
Inc(F);
|
|
end;
|
|
P := F + 1;
|
|
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 P[0] in 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 P[0] in StSkip do
|
|
Inc(P);
|
|
until F1 = P;
|
|
|
|
F := P;
|
|
if FStyle <> psHtml then
|
|
begin
|
|
if P[0] in IdentifierFirstSymbols then
|
|
{ token }
|
|
begin
|
|
while P[0] in IdentifierSymbols do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if P[0] in DigitSymbols then
|
|
{ number }
|
|
begin
|
|
while (P[0] in DigitSymbols) or (P[0] = '.') do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if (Style = psPascal) and (P[0] = '$') and
|
|
(P[1] in HexadecimalSymbols) then
|
|
{ pascal hex number }
|
|
begin
|
|
Inc(P);
|
|
while (P[0] in HexadecimalSymbols) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if (Style = psPerl) and (P[0] in ['$', '@', '%', '&']) then
|
|
{ perl identifier }
|
|
begin
|
|
Inc(P);
|
|
while (P[0] in IdentifierSymbols) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if P[0] = '''' then
|
|
{ pascal string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if P[0] = '''' then
|
|
if P[1] = '''' then
|
|
Inc(P)
|
|
else
|
|
Break;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
I := 2;
|
|
while I < Length(Result) - 1 do
|
|
begin
|
|
if Result[I] = '''' then
|
|
Delete(Result, I, 1);
|
|
Inc(I);
|
|
end;
|
|
end
|
|
else
|
|
if (FStyle in [psCpp, psCocoR]) and (P[0] = '"') then
|
|
{ C++ string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if (P[0] = '"') and (P[-1] <> '\') then
|
|
Break;
|
|
if (P[0] = '"') and (P[-1] = '\') then
|
|
begin
|
|
// count the backslashes, on even backslahses it is a string end
|
|
I := 1;
|
|
while (P - 1 - I > F) and (P[-1 - I] = '\') do
|
|
Inc(I);
|
|
if I and $01 = 0 then
|
|
Break; { same but faster than: if I mod 2 = 0 then Break; }
|
|
end;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if ((FStyle in [psPython, psVB, psHtml]) and (P[0] = '"')) or
|
|
((FStyle in [psPerl, psPhp]) and (P[0] = '"') and ((P = FpcPos) or (P[-1] <> '/'))) then
|
|
{ Python, VB, Html, Perl string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if P[0] = '"' then
|
|
Break;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if P[0] = #0 then
|
|
Result := ''
|
|
else
|
|
begin
|
|
Result := P[0];
|
|
Inc(P);
|
|
end;
|
|
end
|
|
else { html }
|
|
begin
|
|
if (P[0] in ['=', '<', '>']) or
|
|
((P <> pcProgram) and (P[0] = '/') and (P[-1] = '<')) then
|
|
begin
|
|
Result := P[0];
|
|
Inc(P);
|
|
end
|
|
else
|
|
if P[0] = '"' then
|
|
{ Html string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if P[0] = '"' then
|
|
Break;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
begin
|
|
while not (P[0] in [#0, ' ', '=', '<', '>']) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end;
|
|
end;
|
|
Return;
|
|
end;
|
|
|
|
function TJvIParser.HistoryInd(Index: Integer): Integer;
|
|
begin
|
|
Result := FHistoryPtr - 1 - Index;
|
|
if Result < 0 then
|
|
Result := Result + FHistorySize;
|
|
end;
|
|
|
|
function TJvIParser.GetHistory(Index: Integer): string;
|
|
begin
|
|
Result := FHistory[HistoryInd(Index)];
|
|
end;
|
|
|
|
function TJvIParser.GetPosEnd(Index: Integer): Integer;
|
|
begin
|
|
Result := Integer(FHistory.Objects[HistoryInd(Index)]) + 1;
|
|
end;
|
|
|
|
function TJvIParser.GetPosBeg(Index: Integer): Integer;
|
|
var
|
|
I: Integer;
|
|
S: string;
|
|
begin
|
|
I := HistoryInd(Index);
|
|
S := FHistory[I];
|
|
Result := Integer(FHistory.Objects[I]) - Length(S) + 1;
|
|
case FStyle of
|
|
psPascal:
|
|
if S[1] = '''' then
|
|
for I := 2 to Length(S) - 1 do
|
|
if S[I] = '''' then
|
|
Dec(Result);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIParser.SetHistorySize(Size: Integer);
|
|
begin
|
|
while Size > FHistorySize do
|
|
begin
|
|
FHistory.Add('');
|
|
Inc(FHistorySize);
|
|
end;
|
|
while Size < FHistorySize do
|
|
begin
|
|
FHistory.Delete(0);
|
|
Dec(FHistorySize);
|
|
end;
|
|
FHistoryPtr := 0;
|
|
end;
|
|
|
|
function TJvIParser.GetPos: Integer;
|
|
begin
|
|
Result := pcPos - FpcProgram;
|
|
end;
|
|
|
|
procedure TJvIParser.RollBack(Index: Integer);
|
|
begin
|
|
FpcPos := PosEnd[Index] + FpcProgram;
|
|
Dec(FHistoryPtr, Index);
|
|
if FHistoryPtr < 0 then
|
|
FHistoryPtr := FHistorySize + FHistoryPtr;
|
|
end;
|
|
|
|
//=== { TJvIParserW } ========================================================
|
|
|
|
constructor TJvIParserW.Create;
|
|
begin
|
|
inherited Create;
|
|
FHistory := TWStringList.Create;
|
|
HistorySize := 10;
|
|
Style := psPascal;
|
|
end;
|
|
|
|
destructor TJvIParserW.Destroy;
|
|
begin
|
|
FHistory.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJvIParserW.Token: WideString;
|
|
const
|
|
StSkip = [' ', Lf, Cr];
|
|
var
|
|
P, F: PWideChar;
|
|
F1: PWideChar;
|
|
I: Integer;
|
|
|
|
function SkipComments: Boolean;
|
|
begin
|
|
SkipComments := True;
|
|
case P[0] of
|
|
'{':
|
|
if FStyle = psPascal then
|
|
begin
|
|
F := StrScanW(P + 1, WideChar('}'));
|
|
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
|
|
if P[2] = #0 then
|
|
Exit; // line end
|
|
F := P + 2;
|
|
while True do
|
|
begin
|
|
F := StrScanW(F, WideChar('*'));
|
|
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 := StrScanW(P + 1, WideChar(Cr));
|
|
if F = nil then
|
|
F := StrEndW(P + 1);
|
|
P := F;
|
|
end
|
|
else
|
|
if (FStyle in [psCpp, psCocoR, psPhp, psSQL]) and (P[1] = '*') then
|
|
begin
|
|
if P[2] = #0 then
|
|
Exit; // line end
|
|
F := P + 2;
|
|
while True do
|
|
begin
|
|
F := StrScanW(F, WideChar('*'));
|
|
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 [Lf, Cr])) }then
|
|
begin
|
|
F := StrScanW(P + 1, WideChar(Cr));
|
|
if F = nil then
|
|
F := StrEndW(P + 1);
|
|
P := F;
|
|
end;
|
|
'''':
|
|
if FStyle = psVB then
|
|
begin
|
|
F := StrScanW(P + 1, WideChar(Cr));
|
|
if F = nil then
|
|
F := StrEndW(P + 1);
|
|
P := F;
|
|
end;
|
|
// Support for the SQL -- comments
|
|
'-':
|
|
if (FStyle = psSql) and (P[1] = '-') then
|
|
begin
|
|
F := StrScanW(P + 1, WideChar(Cr));
|
|
if F = nil then
|
|
F := StrEndW(P + 1);
|
|
P := F;
|
|
end;
|
|
// Support for multiline comments for HTML
|
|
'<':
|
|
if (FStyle = psHtml) and (P[1] = '!') then
|
|
begin
|
|
// we need the next 2 chars to be --
|
|
if (P[2] = #0) or (P[3] = #0) then
|
|
Exit; // line end
|
|
if (P[2] <> '-') and (P[3] <> '-') then
|
|
Exit;
|
|
F := P + 3;
|
|
while True do
|
|
begin
|
|
F := StrScanW(F, WideChar('-'));
|
|
if F = nil then //IParserError(ieBadRemark, P - FpcProgram);
|
|
Exit;
|
|
if (F[1] = '-') and (F[2] = '>') then
|
|
begin
|
|
Inc(F, 2);
|
|
Break;
|
|
end;
|
|
Inc(F);
|
|
end;
|
|
P := F + 1;
|
|
end;
|
|
end;
|
|
SkipComments := False;
|
|
end;
|
|
|
|
procedure Return;
|
|
begin
|
|
FpcPos := P;
|
|
FHistory.PStrings[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 CharInSetW(P[0], StSkip) do
|
|
Inc(P);
|
|
F1 := P;
|
|
try
|
|
if SkipComments then
|
|
P := StrEndW(F1);
|
|
except
|
|
on E: EJvIParserError do
|
|
if (E.ErrCode = ieBadRemark) and ReturnComments then
|
|
P := StrEndW(F1)
|
|
else
|
|
raise;
|
|
end;
|
|
if ReturnComments and (P > F1) then
|
|
begin
|
|
SetString(Result, F1, P - F1);
|
|
Return;
|
|
Exit;
|
|
end;
|
|
while CharInSetW(P[0], StSkip) do
|
|
Inc(P);
|
|
until F1 = P;
|
|
|
|
F := P;
|
|
if FStyle <> psHtml then
|
|
begin
|
|
if CharInSetW(P[0], IdentifierFirstSymbols) then
|
|
{ token }
|
|
begin
|
|
while CharInSetW(P[0], IdentifierSymbols) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if CharInSetW(P[0], DigitSymbols) then
|
|
{ number }
|
|
begin
|
|
while CharInSetW(P[0], DigitSymbols) or (P[0] = '.') do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if (Style = psPascal) and (P[0] = '$') and
|
|
CharInSetW(P[1], HexadecimalSymbols) then
|
|
{ pascal hex number }
|
|
begin
|
|
Inc(P);
|
|
while CharInSetW(P[0], HexadecimalSymbols) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if (Style = psPerl) and CharInSetW(P[0], ['$', '@', '%', '&']) then
|
|
{ perl identifier }
|
|
begin
|
|
Inc(P);
|
|
while CharInSetW(P[0], IdentifierSymbols) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if P[0] = '''' then
|
|
{ pascal string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if P[0] = '''' then
|
|
if P[1] = '''' then
|
|
Inc(P)
|
|
else
|
|
Break;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
I := 2;
|
|
while I < Length(Result) - 1 do
|
|
begin
|
|
if Result[I] = '''' then
|
|
Delete(Result, I, 1);
|
|
Inc(I);
|
|
end;
|
|
end
|
|
else
|
|
if (FStyle in [psCpp, psCocoR]) and (P[0] = '"') then
|
|
{ C++ string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if (P[0] = '"') and (P[-1] <> '\') then
|
|
Break;
|
|
if (P[0] = '"') and (P[-1] = '\') then
|
|
begin
|
|
// count the backslashes, on even backslahses it is a string end
|
|
I := 1;
|
|
while (P - 1 - I > F) and (P[-1 - I] = '\') do
|
|
Inc(I);
|
|
if I and $01 = 0 then
|
|
Break; { same but faster than: if I mod 2 = 0 then Break; }
|
|
end;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if ((FStyle in [psPython, psVB, psHtml]) and (P[0] = '"')) or
|
|
((FStyle in [psPerl, psPhp]) and (P[0] = '"') and ((P = FpcPos) or (P[-1] <> '/'))) then
|
|
{ Python, VB, Html, Perl string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if P[0] = '"' then
|
|
Break;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
if P[0] = #0 then
|
|
Result := ''
|
|
else
|
|
begin
|
|
Result := P[0];
|
|
Inc(P);
|
|
end;
|
|
end
|
|
else { html }
|
|
begin
|
|
if CharInSetW(P[0], ['=', '<', '>']) or
|
|
((P <> pcProgram) and (P[0] = '/') and (P[-1] = '<')) then
|
|
begin
|
|
Result := P[0];
|
|
Inc(P);
|
|
end
|
|
else
|
|
if P[0] = '"' then
|
|
{ Html string constant }
|
|
begin
|
|
Inc(P);
|
|
while P[0] <> #0 do
|
|
begin
|
|
if P[0] = '"' then
|
|
Break;
|
|
Inc(P);
|
|
end;
|
|
if P[0] <> #0 then
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end
|
|
else
|
|
begin
|
|
while not CharInSetW(P[0], [#0, ' ', '=', '<', '>']) do
|
|
Inc(P);
|
|
SetString(Result, F, P - F);
|
|
end;
|
|
end;
|
|
Return;
|
|
end;
|
|
|
|
function TJvIParserW.HistoryInd(Index: Integer): Integer;
|
|
begin
|
|
Result := FHistoryPtr - 1 - Index;
|
|
if Result < 0 then
|
|
Result := Result + FHistorySize;
|
|
end;
|
|
|
|
function TJvIParserW.GetHistory(Index: Integer): WideString;
|
|
begin
|
|
Result := FHistory[HistoryInd(Index)];
|
|
end;
|
|
|
|
function TJvIParserW.GetPosEnd(Index: Integer): Integer;
|
|
begin
|
|
Result := Integer(FHistory.Objects[HistoryInd(Index)]) + 1;
|
|
end;
|
|
|
|
function TJvIParserW.GetPosBeg(Index: Integer): Integer;
|
|
var
|
|
I: Integer;
|
|
S: WideString;
|
|
begin
|
|
I := HistoryInd(Index);
|
|
S := FHistory[I];
|
|
Result := Integer(FHistory.Objects[I]) - Length(S) + 1;
|
|
case FStyle of
|
|
psPascal:
|
|
if S[1] = '''' then
|
|
for I := 2 to Length(S) - 1 do
|
|
if S[I] = '''' then
|
|
Dec(Result);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIParserW.SetHistorySize(Size: Integer);
|
|
begin
|
|
while Size > FHistorySize do
|
|
begin
|
|
FHistory.Add('');
|
|
Inc(FHistorySize);
|
|
end;
|
|
while Size < FHistorySize do
|
|
begin
|
|
FHistory.Delete(0);
|
|
Dec(FHistorySize);
|
|
end;
|
|
FHistoryPtr := 0;
|
|
end;
|
|
|
|
function TJvIParserW.GetPos: Integer;
|
|
begin
|
|
Result := pcPos - FpcProgram;
|
|
end;
|
|
|
|
procedure TJvIParserW.RollBack(Index: Integer);
|
|
begin
|
|
FpcPos := PosEnd[Index] + FpcProgram;
|
|
Dec(FHistoryPtr, Index);
|
|
if FHistoryPtr < 0 then
|
|
FHistoryPtr := FHistorySize + FHistoryPtr;
|
|
end;
|
|
|
|
//============================================================================
|
|
|
|
procedure ParseString(const S: string; Ss: TStrings);
|
|
var
|
|
Parser: TJvIParser;
|
|
Token: string;
|
|
begin
|
|
Ss.BeginUpdate;
|
|
Ss.Clear;
|
|
Parser := TJvIParser.Create;
|
|
try
|
|
Parser.pcProgram := PChar(S);
|
|
Parser.pcPos := Parser.pcProgram;
|
|
Token := Parser.Token;
|
|
while Token <> '' do
|
|
begin
|
|
Ss.Add(Token);
|
|
Token := Parser.Token;
|
|
end;
|
|
finally
|
|
Parser.Free;
|
|
Ss.EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
procedure ParseStringW(const S: WideString; Ss: TWStrings);
|
|
var
|
|
Parser: TJvIParserW;
|
|
Token: WideString;
|
|
begin
|
|
Ss.BeginUpdate;
|
|
Ss.Clear;
|
|
Parser := TJvIParserW.Create;
|
|
try
|
|
Parser.pcProgram := PWideChar(S);
|
|
Parser.pcPos := Parser.pcProgram;
|
|
Token := Parser.Token;
|
|
while Token <> '' do
|
|
begin
|
|
Ss.Add(Token);
|
|
Token := Parser.Token;
|
|
end;
|
|
finally
|
|
Parser.Free;
|
|
Ss.EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
function IsStringConstant(const St: string): Boolean;
|
|
var
|
|
LS: Integer;
|
|
begin
|
|
LS := Length(St);
|
|
Result := (LS >= 2) and (((St[1] = '''') and (St[LS] = '''')) or
|
|
((St[1] = '"') and (St[LS] = '"')));
|
|
end;
|
|
|
|
function IsStringConstantW(const St: WideString): Boolean;
|
|
var
|
|
LS: Integer;
|
|
begin
|
|
LS := Length(St);
|
|
Result := (LS >= 2) and (((St[1] = '''') and (St[LS] = '''')) or
|
|
((St[1] = '"') and (St[LS] = '"')));
|
|
end;
|
|
|
|
function IsRealConstant(const St: string): Boolean;
|
|
var
|
|
I, J: Integer;
|
|
Point: Boolean;
|
|
begin
|
|
Result := False;
|
|
if (St = '.') or (St = '') then
|
|
Exit;
|
|
if St[1] = '-' then
|
|
if Length(St) = 1 then
|
|
Exit
|
|
else
|
|
J := 2
|
|
else
|
|
J := 1;
|
|
Point := False;
|
|
for I := J to Length(St) do
|
|
if St[I] = '.' then
|
|
if Point then
|
|
Exit
|
|
else
|
|
Point := True
|
|
else
|
|
if not (St[I] in DigitSymbols) then
|
|
Exit;
|
|
Result := True;
|
|
end;
|
|
|
|
function IsRealConstantW(const St: WideString): Boolean;
|
|
var
|
|
I, J: Integer;
|
|
Point: Boolean;
|
|
begin
|
|
Result := False;
|
|
if (St = '.') or (St = '') then
|
|
Exit;
|
|
if St[1] = '-' then
|
|
if Length(St) = 1 then
|
|
Exit
|
|
else
|
|
J := 2
|
|
else
|
|
J := 1;
|
|
Point := False;
|
|
for I := J to Length(St) do
|
|
if St[I] = '.' then
|
|
if Point then
|
|
Exit
|
|
else
|
|
Point := True
|
|
else
|
|
if (St[I] < WideChar('0')) or (St[I] > WideChar('9')) then
|
|
Exit;
|
|
Result := True;
|
|
end;
|
|
|
|
function IsIntConstant(const St: string): Boolean;
|
|
var
|
|
I, J: Integer;
|
|
Sym: TSysCharSet;
|
|
begin
|
|
Result := False;
|
|
if (Length(St) = 0) or ((Length(St) = 1) and (St[1] = '$')) then
|
|
Exit;
|
|
Sym := DigitSymbols;
|
|
if (St[1] = '-') or (St[1] = '$') then
|
|
begin
|
|
if Length(St) = 1 then
|
|
Exit
|
|
else
|
|
J := 2;
|
|
if St[1] = '$' then
|
|
Sym := HexadecimalSymbols;
|
|
end
|
|
else
|
|
J := 1;
|
|
for I := J to Length(St) do
|
|
if not (St[I] in Sym) then
|
|
Exit;
|
|
Result := True;
|
|
end;
|
|
|
|
function IsIntConstantW(const St: WideString): Boolean;
|
|
var
|
|
I, J: Integer;
|
|
Sym: TSysCharSet;
|
|
begin
|
|
Result := False;
|
|
if (Length(St) = 0) or ((Length(St) = 1) and (St[1] = '$')) then
|
|
Exit;
|
|
Sym := DigitSymbols;
|
|
if (St[1] = '-') or (St[1] = '$') then
|
|
begin
|
|
if Length(St) = 1 then
|
|
Exit
|
|
else
|
|
J := 2;
|
|
if St[1] = '$' then
|
|
Sym := HexadecimalSymbols;
|
|
end
|
|
else
|
|
J := 1;
|
|
for I := J to Length(St) do
|
|
if not CharInSetW(St[I], Sym) then
|
|
Exit;
|
|
Result := True;
|
|
end;
|
|
|
|
function IsIdentifier(const ID: string): Boolean;
|
|
var
|
|
I, L: Integer;
|
|
begin
|
|
Result := False;
|
|
L := Length(ID);
|
|
if L = 0 then
|
|
Exit;
|
|
if not (ID[1] in IdentifierFirstSymbols) then
|
|
Exit;
|
|
for I := 1 to L do
|
|
begin
|
|
if not (ID[1] in IdentifierSymbols) then
|
|
Exit;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function IsIdentifierW(const ID: WideString): Boolean;
|
|
var
|
|
I, L: Integer;
|
|
begin
|
|
Result := False;
|
|
L := Length(ID);
|
|
if L = 0 then
|
|
Exit;
|
|
if not CharInSetW(ID[1], IdentifierFirstSymbols) then
|
|
Exit;
|
|
for I := 1 to L do
|
|
begin
|
|
if not CharInSetW(ID[1], IdentifierSymbols) then
|
|
Exit;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function GetStringValue(const St: string): string;
|
|
begin
|
|
if IsStringConstant(St) then
|
|
Result := Copy(St, 2, Length(St) - 2)
|
|
else
|
|
Result := St;
|
|
end;
|
|
|
|
function GetStringValueW(const St: WideString): WideString;
|
|
begin
|
|
if IsStringConstant(St) then
|
|
Result := Copy(St, 2, Length(St) - 2)
|
|
else
|
|
Result := St;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
initialization
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
|
|
finalization
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
end.
|
|
|