{******************************************************************************}
{                                                                              }
{ Project JEDI Code Library (JCL)                                              }
{                                                                              }
{ 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/ }
{                                                                              }
{ Software distributed under the License is distributed on an "AS IS" basis,   }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License.    }
{                                                                              }
{ The Original Code is JclSscanf.pas.                                          }
{                                                                              }
{ The Initial Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C)   }
{ of these individuals.                                                        }
{                                                                              }
{******************************************************************************}
{                                                                              }
{ Pascal implementation of the C/C++ sscanf (String Scan Format) function.     }
{                                                                              }
{ Unit owner:                                                                  }
{ Last modified: January 30, 2001                                              }
{                                                                              }
{******************************************************************************}

unit JclSscanf;

{$I JCL.INC}

{$WEAKPACKAGEUNIT ON}

interface

uses
  SysUtils,
  JclBase;

function Sscanf(const Data: string; const Format: string; const Args: array of const): Integer;

type
  EJclSscanfError = class (EJclError);

implementation

uses
  JclResources, JclStrings;

type
  TFieldKind = (ftChar, ftSmallInt, ftInteger, ftInt64, ftFloating, ftCurrency,
    ftString, ftHex, ftPointer, ftCount, ftUnsigned, ftLiteral, ftWhiteSpace);

//------------------------------------------------------------------------------

procedure CreateSet(Source: string; var ResultSet: TSysCharSet);
var
  At: Integer;
  Token: Char;
  EndToken: Char;
  LoopToken: Char;
  Negate: Boolean;

  function GetToken(IsLiteral: Boolean): Char;
  begin
    if At <= Length(Source) then
    begin
      Result := Source[At];
      Inc(At);
      if not IsLiteral then
      begin
        if Result = '\' then  // Literal character.
          Result := GetToken(True);
        // Provides support for embedded control characters with the standard
        // Pascal ^a format. Removed because ^ has a special meaning for scanf
        // sets. Kept for future reference.
        (*
        else
        if Result ='^' then
        begin
          Result := UpCase(GetToken(True));
          if not Result in [#64..#95] then
            raise EJclSscanfError.Create(RsSscanfBadSet + Source);
          Result := Char(Byte(Result)-64);
        end;
        *)
      end;
    end
    else
      raise EJclSscanfError.Create(RsSscanfBadSet + Source);
  end;

begin
  ResultSet := [];
  At := 1;
  Negate := (Copy(Source, 1, 1) = '^');
  if Negate then
  begin
    Delete(Source, 1, 1);
    ResultSet := [#0..#255];
  end;
  while At <= Length(Source) do
  begin
    Token := GetToken(False);
    EndToken := Token;
    if (Copy(Source, At, 1) = '-') and (At <> Length(Source)) then  // This is a range.
    begin
      Inc(At, 1);  // Go past dash.
      if At > Length(Source) then
        raise EJclSscanfError.Create(RsSscanfBadSet + Source);
      EndToken := GetToken(False);
    end;
    if EndToken < Token then  // Z-A is probably the result of a missing letter.
      raise EJclSscanfError.Create(RsSscanfBadSet + Source);
    if Negate then
      for LoopToken := Token to EndToken do
        Exclude(ResultSet, LoopToken)
    else
      for LoopToken := Token to EndToken do
        Include(ResultSet, LoopToken);
  end;
end;

//------------------------------------------------------------------------------

function GetToken(const Str: string; var At: Integer): Char;
begin
  if At <= Length(Str) then
  begin
    Result := Str[At];
    Inc(At);
  end
  else
  begin
    At := Length(Str) + 1;
    raise EJclSscanfError.CreateResRec(@RsSscanfBadFormat);
  end;
end;

//------------------------------------------------------------------------------

function PeekToken(const Str: string; const At: Integer): Char;
begin
  if At <= Length(Str) then
    Result := Str[At]
  else
    Result := #0;
end;

//------------------------------------------------------------------------------

function GetScanfToken(const Format: string; var At: Integer): string;
var
  Token: Char;
  TokenDone: Boolean;
  BuildingSet: Boolean;
begin
  Token := GetToken(Format, At);
  if Token = '%' then
  begin
    Result := Token;
    BuildingSet := False;
    TokenDone := False;
    repeat
      Token := GetToken(Format, At);
      Result := Result + Token;
      if (Token = '\') and BuildingSet then
      begin
        Token := GetToken(Format, At);
        Result := Result + Token;
      end
      else
      if Token = '[' then
        BuildingSet := True
      else
      if Token = ']' then
      begin
        BuildingSet := False;
        Token := PeekToken(Format, At);
        if Token in ['C', 'c'] then
        begin
          Token := GetToken(Format, At);
          Result := Result + Token;
        end;
        TokenDone := True;
      end
      else
      if (Token in ['*', '0'..'9']) or BuildingSet then
      begin
        // Data is accepted and added to the tag.
      end
      else
        TokenDone := True;
    until TokenDone;
  end
  else
  begin
    Result := Token;
    while Token in AnsiWhiteSpace do
    begin
      Token := PeekToken(Format, At);
      if Token in AnsiWhiteSpace then
        Token := GetToken(Format, At);
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure InterpretScanToken(ScanToken: string; var FieldType: TFieldKind;
  var FieldWidth: Integer; var CharSet: TSysCharSet; var Stored: Boolean);
const
  NumberSet = ['0'..'9', '-'];
  HexSet = ['0'..'9','A'..'F', 'a'..'f', '$', 'x', 'X', '-'];
var
  TokenChar: Char;
  At: Integer;
  EndAt: Integer;
  Frag: string;
  Token: Char;
begin
  CharSet := [];
  if Copy(ScanToken, 1, 1) = '%' then
  begin
    Delete(ScanToken, 1, 1);
    TokenChar := ScanToken[Length(ScanToken)];
    if TokenChar <> ']' then
      Delete(ScanToken, Length(ScanToken), 1)
    else
      TokenChar := 's';
    At := Pos('[', ScanToken);
    if At <> 0 then
    begin
      EndAt := At;
      Token := GetToken(ScanToken, EndAt);
      while Token <> ']' do
      begin
        Token := GetToken(ScanToken, EndAt);
        if Token = '\' then
        begin
          Token := GetToken(ScanToken, EndAt);
          if Token = ']' then
            Token := #0; // Skip Literal ]'s.
        end;
      end;
      Dec(EndAt);
      Frag := Copy(ScanToken, At + 1, EndAt - At - 1);
      Delete(ScanToken, At, EndAt - At + 1);
      CreateSet(Frag, CharSet);
    end
    else
      CharSet := [];
    At := Pos('*', ScanToken);
    Stored := (At = 0);
    if not Stored then
      Delete(ScanToken, At, 1);
    if ScanToken <> '' then
    begin
      try
        FieldWidth := StrToInt(ScanToken);
      except
        raise EJclSscanfError.CreateResRec(@RsSscanfBadFormat);
      end;
    end
    else
      FieldWidth := -1;
    case TokenChar of
      'c':
        begin
          FieldType := ftChar;
          if FieldWidth = -1 then
            FieldWidth := 1;
        end;
      'd':
        begin
          FieldType := ftInteger;
          CharSet := ['0'..'9', '-'];
        end;
      'e', 'f', 'g':
        begin
          FieldType := ftFloating;
          CharSet := ['0'..'9', '.', '+', '-', 'E', 'e'];
        end;
      {$IFDEF SUPPORTS_INT64}
      'i':
        begin
          FieldType := ftInt64;
          CharSet := NumberSet;
        end;
      {$ENDIF SUPPORTS_INT64}
      'h':
        begin
          FieldType := ftSmallInt;
          CharSet := NumberSet;
        end;
      'm':
        begin
          FieldType := ftCurrency;
          CharSet := NumberSet;
        end;
      's':
        begin
           FieldType := ftString;
        end;
      'x':
        begin
          FieldType := ftHex;
          CharSet := HexSet;
        end;
      'p':
        begin
          FieldType := ftPointer; // All pointers are 32 bit.
          CharSet := HexSet;
        end;
      'u':
        begin
          FieldType := ftUnsigned;
          CharSet := ['0'..'9'];
        end;
      '%':
        begin
          FieldType := ftLiteral;
          if (FieldWidth <> -1) or (not Stored) or (CharSet <> []) then
            raise EJclSscanfError.CreateResRec(@RsSscanfBadFormat);
          Stored := False;
        end;
    else
      raise EJclSscanfError.CreateResRec(@RsSscanfBadFormat);
    end;
  end
  else
  begin
    if ScanToken[1] in AnsiWhiteSpace then
    begin
      FieldType := ftWhiteSpace;
      FieldWidth := -1;
      Stored := False;
      CharSet := [];
    end
    else
    begin
      FieldType := ftLiteral;
      FieldWidth := Length(ScanToken);
      Stored := False;
      CharSet := [];
    end;
  end;
end;

//------------------------------------------------------------------------------

function GetDataToken(const Data: string; var DataAt: Integer;
  var OutOfData: Boolean; const FieldType: TFieldKind;
  const FieldWidth: Integer; CharSet: TSysCharSet): string;
var
  Token: Char;
begin
  OutOfData := False;
  Result := '';
  if FieldType = ftChar then
  begin
    try
      GetToken(Data, DataAt);
    except
      OutOfData := True;
      Exit; // Hit End of string.
    end;
  end
  else
  begin
    Token := #32;
    while Token in AnsiWhiteSpace do
    begin
      try
        Token := GetToken(Data, DataAt);
      except
        OutOfData := True;
        Exit; // Hit end of string.
      end;
    end;
    if FieldType = ftWhiteSpace then
    begin
      Dec(DataAt);  // Unget the last token.
      Exit;
    end;
  end;

  if CharSet = [] then
  begin
    CharSet := [#0..#255];
    if FieldType <> ftChar then
      CharSet := CharSet-AnsiWhiteSpace;
  end;

  Dec(DataAt);  // Unget the last token.
  while (FieldWidth = -1) or (Length(Result) < FieldWidth) do // Check Length
  begin
    Token := PeekToken(Data, DataAt);
    if Token in CharSet then
    begin
      try
        Token := GetToken(Data, DataAt);
        Result := Result+Token;
      except
        Break;
      end;
    end
    else
      Break;
  end;
end;

//------------------------------------------------------------------------------

function CheckFieldData(Data: string; const FieldType: TFieldKind): Boolean;
begin
  try
    case FieldType of
//      ftChar:
//        begin
//        end;
      ftSmallInt:
        StrToInt(Data);
      ftInteger:
        StrToInt(Data);
      {$IFDEF SUPPORTS_INT64}
      ftInt64:
        StrToInt64(Data);
      {$ENDIF SUPPORTS_INT64}
      ftFloating:
        StrToFloat(Data);
      ftCurrency:
        StrToFloat(Data);
//      ftString:
//        begin
//        end;
      ftHex:
        begin
          if AnsiUpperCase(Copy(Data, 1, 2)) = '0X' then
            Delete(Data, 1, 2);
          if Copy(Data, 1, 1) <> '$' then
            Data := '$'+Data;
          StrToInt(Data);
        end;
      ftPointer:
        StrToInt(Data);
//      ftCount:
//        begin
//        end;
      ftUnsigned:
        StrToInt(Data);
    end;
    Result := True;
  except
    Result := False;
  end;
end;

//------------------------------------------------------------------------------

function StoreData(Data: string; const FieldType: TFieldKind;
  const FieldWidth: Integer; P: Pointer; VType: Integer): Boolean;
begin
  try
    case FieldType of
      ftChar:
        Move(Data[1], P^, FieldWidth);
      ftSmallInt:
        SmallInt(P^) := StrToInt(Data);
      ftInteger:
        Integer(P^) := StrToInt(Data);
      {$IFDEF SUPPORTS_INT64}
      ftInt64:
        Int64(P^) := StrToInt64(Data);
      {$ENDIF SUPPORTS_INT64}
      ftFloating:
        Extended(P^) := StrToFloat(Data);
      ftCurrency:
        Currency(P^) := StrToFloat(Data);
      ftString:
        begin
          if VType = vtString then
            ShortString(P^) := Data
          else
            string(P^) := Data;
        end;
      ftHex:
        begin
          if AnsiUpperCase(Copy(Data, 1, 2)) ='0X' then
            Delete(Data, 1, 2);
          if Copy(Data, 1, 1) <> '$' then
            Data := '$'+Data;
          Integer(P^) := StrToInt(Data);
        end;
      ftPointer:
        Integer(P^) := StrToInt(Data);
      ftCount:
        begin
        end;
      ftUnsigned:
        Cardinal(P^) := StrToInt(Data);
    end;
    Result := True;
  except
    Result := False;
  end;
end;

//------------------------------------------------------------------------------

function Sscanf(const Data: string; const Format: string;
  const Args: array of const): Integer;
var
  At: Integer;
  DataAt: Integer;
  Results: Integer;
  ScanToken: string;
  StringToken: string;
  FieldType: TFieldKind;
  FieldWidth: Integer;
  CharSet: TSysCharSet;
  Stored: Boolean;
  OutOfData: Boolean;
  P: Pointer;
begin
  At := 1;
  DataAt := 1;
  Results := 0;

  while At <= Length(Format) do
  begin
    try
      ScanToken := GetScanfToken(Format, At);
      InterpretScanToken(ScanToken, FieldType, FieldWidth, CharSet, Stored);
    except
      Break;
    end;
    if FieldType <> ftCount then
      StringToken := GetDataToken(Data, DataAt, OutOfData, FieldType, FieldWidth, CharSet);

    if FieldType = ftLiteral then
      if StringToken <> ScanToken then
        Break;

    if not OutOfData then
    begin
      if not CheckFieldData(StringToken, FieldType) then
        Break;
      if Stored then
      begin
        if (Results + Low(Args)) > High(Args) then
          raise EJclSscanfError.CreateResRec(@RsSscanfInsufficient);
        P := Args[Results + Low(Args)].VPointer;
        StoreData(StringToken, FieldType, FieldWidth, P, Args[Results + Low(Args)].VType);
        Inc(Results);
      end;
    end;
  end;
  Result := Results;
end;

end.