//==============================================================================
// Unit:       Parser
//
// Purpose:    Declare abstract Parser class and three concrete derived parsers:
//          *  TDelimiterParser tokenizes the string using a set of delimiters
//          *  TColumnarParser extracts ranges of columns as tokens
//          *  TPatternParser extracts tokens embedded in "static" patterned
//              text.
//
// Copyright:  1997, Palladion Software
//==============================================================================
unit Parser;

interface

uses
	Classes, SysUtils;

type

    //************************************************************************
    // Type:       EParseError                                                
    //                                                                        
    // Purpose:    Exception in parsing string.
    //                                                                        
    //************************************************************************
	EParseError = class( Exception );


    //************************************************************************
    // Type:       TParseExecute                                              
    //                                                                        
    // Purpose:    Method pointer for handling parsed tokens.                 
    //                                                                        
    //************************************************************************
    TParseEvent = procedure( Sender : TObject; Tokens : TStringList ) of object;


    //************************************************************************
    // Type:       TParseStatus                                               
    //                                                                        
    // Purpose:    Current status of parser.                                  
    //                                                                        
    //************************************************************************
    TParseStatus = ( parseInit, parseOk, parseFail );


    //************************************************************************
    // Type:       TParser
    //
    // Purpose:    Abstract interface class for parser hierarchy.
    //
    //************************************************************************
	TParser = class( TObject )

    protected

    	 FOnParse 	    : TParseEvent;
         FStatus        : TParseStatus;
         FTokens	    : TStringList;
         FToParse       : String;

         procedure BeginParse( const strToParse : String );

         function DoParse( const strToParse : String ) : Boolean;
                                                              virtual; abstract;
         function GetTokens : TStringList;

    public

    	 constructor Create;
         destructor Destroy; override;

         property Status  : TParseStatus
             read FStatus
            write FStatus;

         property ToParse : String
             read FToParse
            write BeginParse;

         property Tokens  : TStringList
             read GetTokens;

         function PeekToken : String;
         function PopToken : String;

    //published

         property OnParse : TParseEvent
             read FOnParse
            write FOnParse;

    end;

    //************************************************************************
    // Type:       TDelimiterParser
    //
    // Purpose:    Parse a string into tokens, breaking at any character in   
    //             our delimiter string.                                      
    //                                                                        
    //************************************************************************
    TDelimiterParser = class( TParser )

    protected

    	 FDelimiters : String;

         function DoParse( const strToParse : String ) : Boolean; override;

    public

    	constructor Create;
        destructor Destroy; override;

    //published

    	property Delimiters : String
            read FDelimiters
           write FDelimiters;

    end;

    //************************************************************************
    // Type:       TColumnarParser                                            
    //                                                                        
    // Purpose:    Parse a string into tokens by columns.                     
    //                                                                        
    //************************************************************************
    TColumnarParser = class( TParser )

    protected
    	 FSpecifiers 	: TList;
         FStripChars	: String;

         function DoParse( const strToParse : String ) : Boolean; override;
         procedure SetColumns( const strColumnDesc : String );

    public
    	 constructor Create;
         destructor Destroy; override;

    //published

         property StripChars : String
             read FStripChars
            write FStripChars;

    	 property ColumnDesc : String
            write SetColumns;

    end;

    //************************************************************************
    // Type:       TPatternParser                                             
    //                                                                        
    // Purpose:    Parse a string into tokens using our pattern string as a   
    //             template.                                                  *)
    //                                                                        
    //************************************************************************
	TPatternParser = class( TParser )

    protected
    	FPattern 		: String;
         FPlaceholder	: String;
         FSpecifiers	: TList;		// list of TPatternSpecifiers 

         procedure SetPattern( const strNewPattern : String );
         function DoParse( const strToParse : String ) : Boolean; override;

    public
    	constructor Create;
         destructor Destroy; override;

    //published
    	property Pattern : String read FPattern write SetPattern;
         property Placeholder : String read FPlaceholder write FPlaceholder;
    end;

implementation

type

    //************************************************************************
    // Type:       TPatternSpecifier                                          
    //                                                                        
    // Purpose:    Helper class for TPatternParser:  parse a single token and 
    //             return new position.                                       *)
    //                                                                        
    //************************************************************************
	TPatternSpecifier = class( TObject )

    private
    	FPrefix	  	: String;
         FShouldParse 	: Boolean;  // False if "trailer" specifier. 
         FDelimiters	: String;

    public

    	property Prefix 	 : String  read FPrefix      write FPrefix;
         property ShouldParse : Boolean read FShouldParse write FShouldParse;
         property Delimiters  : String  read FDelimiters  write FDelimiters;

    	// Scan strToParse, skipping text which matches FPrefix.  Then
        //   parse strToken using FDelimiters.  Return the position within
        //   the string with done;  on error, retturn -1.
    	function ParseToken( const strToParse : String; nStart : integer;
         				var strToken : String ) : integer;
    end;

    //************************************************************************
    // Type:       TColumnSpecifier                                           
    //                                                                        
    // Purpose:    Helper class for TColumnParser:  parse a single token and  
    //             return true / false to indicate success.                   *)
    //                                                                        
    //************************************************************************
	TColumnSpecifier = class( TObject )

    private

    	FColStart		: integer;
         FColWidth		: integer;
         FStripChars	: String;

         function GetColEnd : integer;
         procedure SetColEnd( nNewEnd : integer );

    public

    	property ColStart	: integer read FColStart   write FColStart;
         property ColWidth	: integer read FColWidth   write FColWidth;
         property ColEnd     : integer read GetColEnd   write SetColEnd;
         property StripChars	: String  read FStripChars write FStripChars;

    	function ParseToken( const strToParse : String;
         				 var strToken : String ) : Boolean;
    end;


//************************************************************************
// TParser Implementation                                                   
//************************************************************************

constructor TParser.Create;
begin
	inherited Create;

	FTokens := TStringList.Create;
    FStatus := parseInit;
    FOnParse := Nil;
end;

destructor TParser.Destroy;
begin
	FTokens.Free;
    inherited Destroy;
end;

function TParser.GetTokens : TStringList;
begin
	if FStatus = parseOk then
    begin
    	Result := FTokens;
    end
    else
    begin
    	raise EParseError.Create( 'TPatternParser.Tokens accessed before successful parse.' );
    end;
end;


function TParser.PeekToken : String;
var
	stlTokens	: TStringList;
begin

	stlTokens := GetTokens;

    if ( stlTokens.Count > 0 ) then
    begin
    	Result := stlTokens[ 0 ];
    end
    else
    begin
    	Result := '';
    end;
end;


function TParser.PopToken : String;
var
	stlTokens	: TStringList;
begin

	stlTokens := GetTokens;

    if ( stlTokens.Count > 0 ) then
    begin
    	Result := stlTokens[ 0 ];
         stlTokens.Delete( 0 );
    end
    else
    begin
    	Result := '';
    end;
end;


procedure TParser.BeginParse( const strToParse : String );
begin

	FToParse := strToParse;

    if ( FToParse = '' ) then
    begin
    	FStatus := parseInit;
    end
    else
    begin

    	if ( DoParse( strToParse ) ) then
         begin
         	FStatus := parseOk;

              if Assigned( FOnParse ) then
              begin
                   FOnParse( Self, FTokens );
              end;
         end
         else
         begin
         	FStatus := parseFail;
         end;

    end;

end;


//************************************************************************
// TDelimiterParser Implementation                                          
//************************************************************************

constructor TDelimiterParser.Create;
begin
	inherited Create;
end;

destructor TDelimiterParser.Destroy;
begin
	inherited Destroy;
end;

function TDelimiterParser.DoParse( const strToParse : String ) : Boolean;
var
	i, nLast	: integer;
begin

    FTokens.Clear;
    nLast := 0;

    for i := 1 to Length( strToParse ) do
    begin
    	if ( Pos( strToParse[i], FDelimiters ) > 0 ) then
		begin

         	if ( i - nLast > 1 ) then	// No empty tokens 
              begin
         	    FTokens.Add( Copy( strToParse, nLast + 1, i - nLast - 1 ) );
              end;

              nLast := i;
         end;
    end;

    if ( nLast < Length( strToParse ) ) then
    begin
		FTokens.Add( Copy( strToParse, nLast + 1, 999 ) );
    end;

    Result := ( FTokens.Count > 0 );
end;


//************************************************************************
// TPatternParser Implementation                                            
//************************************************************************

constructor TPatternParser.Create;
begin
	inherited Create;
	FSpecifiers := TList.Create;
end;

destructor TPatternParser.Destroy;
begin
	FSpecifiers.Free;            
    inherited Destroy;
end;


function TPatternParser.DoParse( const strToParse : String ) : Boolean;
var
	iSpecifier 	: integer;
    iCharPos   	: integer;
    strToken		: String;
    specifier		: TPatternSpecifier;
begin

	FTokens.Clear;
	Result := False;
	iCharPos := 1;

	for iSpecifier := 0 to FSpecifiers.Count - 1 do
    begin
    	specifier := FSpecifiers.Items[ iSpecifier ];
         iCharPos := specifier.ParseToken( strToParse, iCharPos, strToken );

         if( iCharPos > 0 ) then
         begin
         	if specifier.ShouldParse then
         		FTokens.Add( strToken );
         end
         else
         begin
			exit;
         end;
    end;

    Result := True;
end;


procedure TPatternParser.SetPattern( const strNewPattern : String );
var
	iPrefix	: integer;
    prefixes  : TStringList;
    dp		: TDelimiterParser;
    specifier	: TPatternSpecifier;
    strTmp	: String;
begin

	FPattern := strNewPattern;
    FSpecifiers.Clear;

	dp := TDelimiterParser.Create;

    dp.Delimiters := FPlaceholder;
    dp.ToParse := strNewPattern;

    if ( dp.Status = parseOk ) then
    begin
    	prefixes := dp.Tokens;

    	for iPrefix := 0 to prefixes.Count - 1 do
         begin
         	specifier := TPatternSpecifier.Create;
              specifier.Prefix := prefixes[ iPrefix ];

              if ( iPrefix < prefixes.Count - 1 ) then // set delimiter
              begin
              	specifier.Delimiters := prefixes[ iPrefix + 1 ][1];
                   specifier.ShouldParse := True;
              end
              else
              begin
              	specifier.Delimiters := '';
                   strTmp :=
                     Copy( strNewPattern,
                   	   Length( strNewPattern ) - Length( FPlaceHolder ) + 1,
                           Length( FPlaceHolder ) );
                   specifier.ShouldParse := ( strTmp = FPlaceHolder );
              end;

              FSpecifiers.Add( specifier );
         end;
    end
    else
    begin
    	specifier := TPatternSpecifier.Create;
         specifier.Prefix := strNewPattern;
         specifier.ShouldParse := False;
         specifier.Delimiters := ' ';
         FSpecifiers.Add( specifier );
    end;

    dp.Free;
end;


//************************************************************************
// TPatternSpecifier Implementation                                         
//************************************************************************

function TPatternSpecifier.ParseToken( const strToParse : String; nStart : integer;
         						var strToken : String ) : integer;
var
	iPos, jPos	: integer;
begin

	iPos := nStart;

    // Test / strip prefix. 
    for jPos := 1 to Length( FPrefix ) do
    begin
    	if ( strToParse[iPos] <> FPrefix[jPos] ) then
         begin
         	Result := -iPos;
              exit;
         end
         else
         begin
         	iPos := iPos + 1;
         end;
    end;

    jPos := iPos;

    while FShouldParse and ( jPos <= Length( strToParse ) ) do
    begin
    	if ( Pos( strToParse[jPos], FDelimiters ) > 0 ) then
         begin
         	break;
         end
         else
         begin
         	jPos := jPos + 1;
         end;
    end;

    // Assertion:  jpos now points to next character past the parsed token,
    //    			or to iPos if no parsing done. 
    if  ( jPos > iPos ) then
    begin
    	strToken := Copy( strToParse, iPos, jPos - iPos );
         Result := jPos;
    end
    else
    begin
    	if not FShouldParse then
         begin
         	Result := iPos;
              strToken := '';
         end
         else
         begin
    		Result := -iPos;
         end;
    end;

end;


//************************************************************************
// TColumnarParser Implementation                                            
//************************************************************************

constructor TColumnarParser.Create;
begin
	inherited Create;
	FSpecifiers := TList.Create;
end;

destructor TColumnarParser.Destroy;
begin
	FSpecifiers.Free;             
    inherited Destroy;
end;

function TColumnarParser.DoParse( const strToParse : String ) : Boolean;
var
	iSpecifier 	: integer;
    strToken		: String;
    specifier		: TColumnSpecifier;
begin

	FTokens.Clear;
	Result := False;

	for iSpecifier := 0 to FSpecifiers.Count - 1 do
    begin
    	specifier := FSpecifiers.Items[ iSpecifier ];
         // Empty tokens are possible!  Not errors, for this parser. 
         specifier.ParseToken( strToParse, strToken );
         FTokens.Add( strToken );
    end;

    Result := True;
end;

procedure TColumnarParser.SetColumns( const strColumnDesc : String );
var
	dp		: TDelimiterParser;
	iToken	: integer;
	nTokens	: integer;
    specifier	: TColumnSpecifier;

begin

	FSpecifiers.Clear;

    if ( strColumnDesc = '' ) then
    begin
    	FStatus := parseInit;
         exit;
    end;

    dp := TDelimiterParser.Create;
    dp.Delimiters := '(, );:';
    dp.ToParse := strColumnDesc;

    if ( dp.Status = parseOk ) then
    begin
    	iToken := 0;
         nTokens := dp.Tokens.Count;

         while ( iToken < nTokens ) do
         begin       
         	specifier := TColumnSpecifier.Create;
         	specifier.StripChars := StripChars;

              if ( iToken < nTokens - 1 ) then // parse start-end pairs 
              begin
                   specifier.ColStart := StrToInt( dp.Tokens[ iToken ] );
                   specifier.ColEnd   := StrToInt( dp.Tokens[ iToken + 1 ] );
                   iToken := iToken + 2;
              end
              else						// parse trailing singleton
              begin
                   specifier.ColStart := strToInt( dp.Tokens[ iToken ] );
                   specifier.ColEnd   := 999;
                   iToken := iToken + 1;
              end;

              FSpecifiers.Add( specifier );
         end;

         FStatus := parseOk;
    end
    else
    begin
    	FStatus := parseFail;
    end;
end;


//************************************************************************
// TColumnSpecifier Implementation
//************************************************************************

function TColumnSpecifier.GetColEnd : integer;
begin
	Result := FColStart + FColWidth - 1;
end;

procedure TColumnSpecifier.SetColEnd( nNewEnd : integer );
begin

	if( nNewEnd <= FColStart ) then
    	raise EParseError.Create( 'TColumnSpecifier.SetColEnd() -- end <= start.' );

    FColWidth := nNewEnd - FColStart + 1;
end;

function TColumnSpecifier.ParseToken( const strToParse : String;
         						var strToken : String ) : Boolean;
var
	iChar 	: integer;
begin
	strToken := Copy( strToParse, FColStart, FColWidth );

    for iChar := Length( strToken ) downto 1 do
    begin
    	if ( Pos( strToken[iChar], FStripChars ) > 0 ) then
         	Delete( strToken, iChar, 1 );
    end;

    Result := ( Length( strToken ) > 0 );
end;

end.