utils/uutlSScanf.pas

unit uutlSScanf;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

function utlSScanf(const s: string; const fmt: string; const Pointers: array of Pointer): Integer;
function utlSScanf(const s: string; const fmt: string; const Pointers: array of Pointer; const FormatSettings: TFormatSettings): Integer;

implementation

function utlSScanf(const s: string; const fmt: string; const Pointers: array of Pointer): Integer;
begin
  Result:= utlSScanf(s, fmt, Pointers, DefaultFormatSettings);
end;

{
   0 on success (perfect match)
  +N if fmt was consumed without error, but there are characters left in s. First unparsed character is N
  -N if there was an error consuming pattern character N

  %s: string, must be terminated by a fixed string in fmt
  %d: integer
  %D: int64
  %f: double, supports scientific notation
  %P: hex PtrUInt (fixed length)
  %x: hex integer
  %X: hex int64
}
function utlSScanf(const s: string; const fmt: string; const Pointers: array of Pointer; const FormatSettings: TFormatSettings): Integer;
var
  pt, fpos, tokfpos, spos:  integer;
  token, limit: string;
  limitChar: Char;
  success: Boolean;

  function nextToken(advance: boolean): string;
  var
    oldfpos: integer;
  begin
    Result:= '';
    oldfpos:= fpos;
    try
      if fpos > Length(fmt) then
        Exit;

      Result:= fmt[fpos];
      inc(fpos);
      if Result = '%' then begin
        if fpos > Length(fmt) then
          Exit;                    // incomplete token, treat as literal %

        Result += fmt[fpos];
        inc(fpos);

        if Result = '%%' then
          Result:= '%';
      end;
    finally
      if not advance then
        fpos:= oldfpos
      else
        tokfpos:= oldfpos;
    end;
  end;

  function GetString: boolean;
  var
    tmp: string;
  begin
    tmp:= '';
    Result:= false;
    if limitChar = #0 then begin
      tmp:= Copy(s, spos, MaxInt);
      inc(spos, length(tmp));
      Result:= true;
    end else begin
      while spos <= Length(s) do begin
        if s[spos] = limitChar then begin
          dec(spos); // consume again
          Result:= true;
          break;
        end;
        tmp:= tmp + s[spos];
        inc(spos);
      end;
    end;
    PString(Pointers[pt])^:= tmp;
  end;

  function GetInteger(i64: boolean): Boolean;
  var
    tmp: string;
    v: int64;
  begin
    tmp:= '';
    Result:= false;
    while spos <= Length(s) do begin
      if s[spos] = limitChar then begin
        dec(spos); // consume again
        break;
      end;
      tmp:= tmp + s[spos];
      if not TryStrToInt64(tmp, v) then begin
        dec(spos);
        SetLength(tmp, Length(tmp) - 1);
        Break;
      end;
      inc(spos);
    end;
    if TryStrToInt64(tmp, v) then begin
      if i64 then
        PInt64(Pointers[pt])^:= v
      else
        PInteger(Pointers[pt])^:= v;
      Result:= true;
    end;
  end;

  function GetFloat: Boolean;
  var
    tmp: string;
    v: double;
    lastChar: char;
    firstFailure, fflen: Integer;
  begin
    tmp:= '';
    Result:= false;
    firstFailure:= 0;
    while spos <= Length(s) do begin
      if s[spos] = limitChar then begin
        dec(spos); // consume again
        break;
      end;
      tmp:= tmp + s[spos];
      if not TryStrToFloat(tmp, v, FormatSettings) then begin
        lastChar:= tmp[length(tmp)];
        if (firstFailure = 0) and
           ((lastChar = FormatSettings.ThousandSeparator) or (lastChar in ['-','E'])) then begin
          firstFailure:= spos;
          fflen:= Length(tmp);
        end else begin
          Break;
        end;
      end else
        firstFailure:= 0;
      inc(spos);
    end;
    if firstFailure > 0 then begin
      spos:= firstFailure;
      dec(spos);
      SetLength(tmp, fflen - 1);
    end;

    if TryStrToFloat(tmp, v, FormatSettings) then begin
      PDouble(Pointers[pt])^:= v;
      Result:= true;
    end;
  end;

  function GetHex(mode: byte): Boolean;
  const
    ptrlen =  Sizeof(PtrUInt) * 2;
  var
    tmp: string;
    v: int64;
  begin
    tmp:= '$';
    Result:= false;
    if mode = 0 then begin
      tmp += Copy(s, spos, ptrlen);
      inc(spos, length(tmp));
      if Length(tmp) <> ptrlen+1 then
        Exit;
    end else
      while spos <= Length(s) do begin
        if s[spos] = limitChar then begin
          dec(spos); // consume again
          break;
        end;
        tmp:= tmp + s[spos];
        if not TryStrToInt64(tmp, v) then begin
          dec(spos);
          SetLength(tmp, Length(tmp) - 1);
          Break;
        end;
        inc(spos);
      end;
    if TryStrToInt64(tmp, v) then begin
      case mode of
        0: PPtrUInt(Pointers[pt])^:= v;
        1: PInteger(Pointers[pt])^:= v;
        2: PInt64(Pointers[pt])^:= v;
      end;
      Result:= true;
    end;
  end;

begin
  pt:= 0;
  fpos:= 1;
  spos:= 1;
  while fpos <= length(fmt) do begin
    if spos > Length(s) then
      Exit(-fpos);

    token:= nextToken(true);

    if token = '' then
      Exit(-tokfpos);

    if Length(token) = 1 then begin
      if token <> s[spos] then
        Exit(-tokfpos);
    end else begin
      limit:= nextToken(false);
      if Length(limit) = 1 then
        limitChar:= limit[1]
      else
        limitChar:= #0;

      case token[2] of
        's': success:= GetString;
        'd': success:= GetInteger(false);
        'D': success:= GetInteger(True);
        'f': success:= GetFloat;
        'P': success:= GetHex(0);
        'x': success:= GetHex(1);
        'X': success:= GetHex(2);
      else
        Exit(-tokfpos);
      end;
      if not success then
        Exit(-tokfpos);

      inc(pt);
    end;
    inc(spos);
  end;
  if spos <= Length(s) then
    Exit(spos)
  else
    Exit(0);
end;

end.