{$IFDEF MSDOS}
{$O+,F+}
{$ENDIF}
{$I-}

Unit
  Parser;

Interface

Uses
  tMisc,
{$IFNDEF WIN32}
  DOS,
{$ELSE}
  OpCrt,
{$ENDIF}
  tGlob,
  Log;

Type
  tConfigParser = Record
    S : String;
    GB, ErrLog, ErrScr : Boolean;
    Handle, Define : PNotSortedCollection;
  End;

  tParType =
    (tptBoolean, tptExtBoolean, tptString, tptUpString, tptFilePath,
     tptQuote, tptFixedList, tptByte, tptWord, tptTime, tptLongInt,
     tptColor);

Const
  tpoWriteLog      = $01;
  tpoWriteScreen   = $02;

Function ParserOpen (Var P: tConfigParser; FN: PathStr; Options: Byte): Boolean;
Function ParserRead (Var P: tConfigParser; Var Section: String): String;
Procedure ParserGetParam (Var P: tConfigParser; ParType: tParType; Valid: String; Var R);
Procedure ParserUnknown (Var P: tConfigParser);
Function ParserEnd (Var P: tConfigParser): Boolean;
Procedure ParserClose (Var P: tConfigParser);
Procedure ParserGetBack (Var P: tConfigParser);

Implementation

Type
  PHandle = ^THandle;
  THandle = Record
    F : Text;
    FName : PathStr;
    LineNo : LongInt;
  End;

  PDefine = ^TDefine;
  TDefine = Record
    KeyWord, Replace : String [128];
  End;

Var
  PH : PHandle;
  PD : PDefine;

Function ParserOpen;
Var
  B  : Boolean;

Begin
  If Trim (FN) <> '' Then
  Begin
    New (PH);

    With P, PH^ Do
    Begin
      GB := False;
      ErrLog := Options And tpoWriteLog <> 0;
      ErrScr := Options And tpoWriteScreen <> 0;
      LineNo := 0;
      FName := FN;
      Assign (F, FN);
      Reset (F);
      B := IOResult = 0;

      If B Then
      Begin
        Handle := New (PNotSortedCollection, Init (1, 1));
        Define := New (PNotSortedCollection, Init (2, 2));
        Handle^. Insert (PH);
      End Else
        Dispose (PH);
    End;
  End Else
    B := False;

  ParserOpen := B;
End;

Procedure ErrWrite (Var P: tConfigParser; Wrong: String);
Begin
  If P. Handle^. Count = 0 Then Exit;

  Wrong := UpString (PHandle (P. Handle^. At (P. Handle^. Count-1))^.
    FName) + ' (' + Long2Str (PHandle (P. Handle^. At (P. Handle^.
    Count-1))^. LineNo) + '): ' + Wrong;

  If P. ErrLog Then LogWrite ('!', Wrong);
  If P. ErrScr Then WriteLn ('! ', Wrong);
End;

Function ParserRead (Var P: tConfigParser; Var Section: String): String;
Var
  F  : Text;
  S1 : String;
  i  : LongInt;

Begin
  ParserRead := '';
  If ParserEnd (P) Then Exit;

  With P Do
  While Not EoF (PHandle (Handle^. At (Handle^. Count-1))^. F) Do
  Begin
    If Not GB Then
    Begin
      Inc (PHandle (Handle^. At (Handle^. Count-1))^. LineNo);
      ReadLn (PHandle (Handle^. At (Handle^. Count-1))^. F, P. S);
      P. S := TrimLead (PlaceSubStr (P. S, #9, '    '));
    End Else
      P. GB := False;

    If (P. S <> '') And (P. S [1] <> ';') Then
    Case P. S [1] Of

      '[': Begin
             Section := UpString (ExtractWord (1, P. S, ['[', ']']));
             Continue;
           End;

      '#': Begin
             S1 := UpString (ExtractWord (1, P. S, [' ']));

             If S1 = '#INCLUDE' Then
             Begin
               New (PH);
               PH^. LineNo := 0;
               PH^. FName := ExtractWord (2, P. S, [' ']);
               Assign (PH^. F, PH^. FName);
               Reset (PH^. F);
               If IOResult = 0 Then P. Handle^. Insert (PH) Else
               Begin
                 ErrWrite (P, 'Unable to find the file specified by #include directive');
                 Dispose (PH);
               End;
               Continue;
             End Else
             If S1 = '#DEFINE' Then
             Begin
               If WordCount (P. S, [' ']) < 3 Then ErrWrite (P, 'Too few arguments for the #define directive') Else
               Begin
                 GetMem (PD, SizeOf (TDefine));
                 PD^. KeyWord := ExtractWord (2, P. S, [' ']);
                 PD^. Replace := Copy (P. S, WordPosition (3, P. S, [' ']), 255);
                 P. Define^. Insert (PD);
               End;
             End Else
               ErrWrite (P, 'Invalid CTL directive');
           End;

    {$IFNDEF NOT_TOR}
      '{': Begin
             i := Pos ('}', P. S);
             If i < 3 Then Continue;
             S1 := Trim (Copy (P. S, 2, i-2));
             While Pos (' ', S1) <> 0 Do Delete (S1, Pos (' ', S1), 1);
             If InRange (BBSline, S1) Then
             Begin
               Delete (P. S, 1, Pos ('}', P. S));
               P. S := TrimLead (P. S);
               ParserRead := UpString (ExtractAscii (1, P. S, [' '], '"'));
               Exit;
             End;
           End;
    {$ENDIF}
    Else
      ParserRead := UpString (ExtractAscii (1, P. S, [' '], '"'));
      Exit;
    End Else
      Continue;
  End;

  Close (PHandle (P. Handle^. At (P. Handle^. Count-1))^. F);
  FreeMem (P. Handle^. At (P. Handle^. Count-1), SizeOf (tHandle));
  P. Handle^. AtDelete (P. Handle^. Count-1);
End;

Procedure ParserGetParam (Var P: tConfigParser; ParType: tParType; Valid: String; Var R);
Var
  S1, S2, S3, Wrong : String;
  i, j : Byte;
  Found : Boolean;
  Err : SysInt;
  w : Word;
  l : LongInt;

Const
  FilePathSymbs : Set Of Char =
    ['0'..'9', ':', '-', '(', ')', '.', '_', '@'..#255, '#', '!', '%', '$', '&', ''''];

Begin
  Wrong := '';
  i := AsciiPosition (2, P. S, [';'], '"')-1;
  If i = 0 Then i := Length (P. S)+1;
  S1 := Trim (Copy (P. S, Pos (' ', P. S), i-Pos (' ', P. S)));

  i := AsciiCount (P. S, ['%'], '"');
  If i > 0 Then
  Begin
    S3 := S1;
    For j := 2 To i Do
    If Not Odd (j) Then
    Begin
      S2 := ExtractAscii (j, S1, ['%'], '"');
      If ConsistsOf (S2, ['A'..'z']) Then
      S3 := PlaceSubStr (S3, '%' + S2 + '%', GetEnv (S2));
    End;
    S1 := S3;
  End;

  With P Do If Define^. Count > 0 Then
  For i := 0 To Define^. Count-1 Do
    S1 := PlaceSubStr (S1,
{    PDefine (Define^. At (Define^. Count-1))^. KeyWord,
    PDefine (Define^. At (Define^. Count-1))^. Replace}
    PDefine (Define^. At (i))^. KeyWord,
    PDefine (Define^. At (i))^. Replace
    );

  Case ParType Of

    tptBoolean :
      Begin
        S1 := UpString (S1);
        If S1 = 'YES' Then Boolean (R) := True Else
        If S1 = 'NO' Then Boolean (R) := False Else
        Wrong := 'Value of the parameter must be Yes or No';
      End;

    tptExtBoolean :
      Begin
        S1 := UpString (S1);
        If S1 = 'YES' Then AskType (R) := atYes Else
        If S1 = 'NO' Then AskType (R) := atNo Else
        If S1 = 'ASK' Then AskType (R) := atAsk Else
        Wrong := 'Value of the parameter must be Yes, No or Ask';
      End;

    tptString :
      String (R) := S1;

    tptUpString :
      String (R) := UpString (S1);

    tptColor :
      Begin
        S1 := UpString (S1);
        Byte (R) := Color2Byte (S1);
        If (Byte (R) = 7) And (S1 <> 'LIGHTGRAY/BLACK') Then Wrong := 'Invalid name of color';
      End;

    tptQuote :
      Begin
        If ((S1 [1] = '"') And (S1 [Length (S1)] = '"')) Or
           ((S1 [1] = '''') And (S1 [Length (S1)] = ''''))
        Then String (R) := Copy (S1, 2, Length (S1)-2)
        Else Wrong := 'Value of the parameter must be in quotes';
      End;

    tptFilePath :
      Begin
        If ConsistsOf (S1, FilePathSymbs)
        Then
          String (R) := S1
        Else
          Wrong := 'Value of the parameter isn''t a path or a filename';
      End;

    tptFixedList :
      Begin
        S1 := UpString (S1);
        Valid := UpString (Valid);
        Found := False;

        For i := 1 To WordCount (Valid, [' ']) Do
        If ExtractWord (i, Valid, [' ']) = S1 Then
        Begin
          Byte (R) := i-1;
          Found := True;
          Break;
        End;

        If Not Found Then Wrong := 'Value of the parameter is out of a fixed range of valid variants';
      End;

    tptByte :
      Begin
        Val (S1, i, Err);
        If Err = 0 Then
        Begin
          If ((Valid <> '') And InRange (i, Valid)) Or (Valid = '')
          Then Byte (R) := i
          Else Wrong := 'Value of the parameter is out of range';
        End Else
          Wrong := 'Value of the parameter must be a number between 0 and 255';
      End;

    tptWord :
      Begin
        Val (S1, w, Err);
        If Err = 0 Then
        Begin
          If ((Valid <> '') And InRange (w, Valid)) Or (Valid = '')
          Then Word (R) := w
          Else Wrong := 'Value of the parameter is out of range';
        End Else
          Wrong := 'Value of the parameter must be a number between 0 and 65535';
      End;

    tptLongInt :
      Begin
        Val (S1, l, Err);
        If Err = 0 Then
        Begin
          If ((Valid <> '') And InRange (l, Valid)) Or (Valid = '')
{          Then Word (R) := l}
          Then LongInt (R) := l
          Else Wrong := 'Value of the parameter is out of range';
        End Else
          Wrong := 'Value of the parameter must be a number between -2147483648 and 2147483647';
      End;

    tptTime :
      Begin
        If ConsistsOf (S1, ['0'..'9', ':', '-', '.', ','])
        Then String (R) := S1
        Else Wrong := 'Invalid time specified';
      End;

  End;

  If Wrong <> '' Then ErrWrite (P, Wrong);
End;

Procedure ParserGetBack (Var P: tConfigParser);
Begin
  P. GB := True;
End;

Function ParserEnd (Var P: tConfigParser): Boolean;
Begin
  ParserEnd := P. Handle^. Count = 0;
End;

Procedure ParserUnknown (Var P: tConfigParser);
Begin
  ErrWrite (P, 'Unknown parameter ' + ExtractWord (1, P. S, [' ']));
End;

Procedure ParserClose (Var P: tConfigParser);
Begin
  While P. Handle^. Count > 0 Do
  Begin
    Close (PHandle (P. Handle^. At (0))^. F);
    FreeMem (P. Handle^. At (0), SizeOf (tHandle));
    P. Handle^. AtDelete (0);
  End;

  While P. Define^. Count > 0 Do
  Begin
    FreeMem (P. Define^. At (0), SizeOf (tDefine));
    P. Define^. AtDelete (0);
  End;

  Dispose (P. Handle, Done);
  Dispose (P. Define, Done);
End;

End.