scanf_c.pas

delphi 实现的 sscanf 函数

function ParseSet(var Format : PChar; FmtEnd : PChar; var Res : TCharSet) : boolean;
type T32Int = array [0..7] of integer;
var TI : T32Int absolute Res;
    i : integer;
    Neg : boolean;
begin // Assume that Format points to a character after opening "["
  Res:=[]; Result:=False;
  If Format >= FmtEnd then Exit;
  If Format^='^' then begin // Check for '^'
    Neg:=True;
    Inc(Format);
    If Format >= FmtEnd then Exit;
  end else Neg:=False;
  Case Format^ of   // Check special cases: first ']' or '-'
    ']','-' :
      begin
        //  Res:=Res+[Format^];
        TI[Byte(Format^) shr 5]:=TI[Byte(Format^) shr 5] or (1 shl ( Byte(Format^) and 31));
        Inc(Format);
      end;
  end;
  while Format < FmtEnd do
    if Format^ = ']' then begin
      Result:=True;
      Inc(Format);
      Break;
    end else
      if (Format[1]='-') and (Format[2] <> ']') then begin // Range
        Res:=Res+[Format^..Format[2]];
        Inc(Format,3);
      end else begin
        // Res:=Res + [Format^];
        TI[Byte(Format^) shr 5]:=TI[Byte(Format^) shr 5] or (1 shl ( Byte(Format^) and 31));
        Inc(Format);
      end;
  if Neg  then
    // Res:=[#0..#255]-Res;
    for i:=0 to 7 do TI[i]:= not TI[i];
end;

// Process [size] type portions of a format specifier
// On error, scIllegal is returned
function GetSizeType(var Format : PChar) : TscRec;
var FType : TscRec;
    PW : ^word absolute Format;
begin
  Integer(Result):=scIllegal; Integer(FType):=0;// Initialization
  With FType do begin
    Case Format^ of  // check size specifiers
      'H','h','L' :
         begin
           Size:=Format^;
           Inc(Format);
         end;
      'l' :
         begin
           Inc(Format);
           Case Format^ of
             '8' : begin Size:='H'; Inc(Format); Flags:=Flags or scIntSpec; end;
             'l' : begin Size:='L'; Inc(Format); end;
           else
             Case PW^ of
              $3631 {'16'} : begin Size:='h'; Inc(Format,2); Flags:=Flags or scIntSpec; end;
              $3332 {'32'} : begin Size:='l'; Inc(Format,2); Flags:=Flags or scIntSpec; end;
              $3436 {'64'} : begin Size:='L'; Inc(Format,2); Flags:=Flags or scIntSpec; end;
             else Size:='l';
             end;
           end;
         end;
    end;
    Case UpCase(Format^) of
      #0  : Exit;
      '[' : Typ:=scCharSet;
      'I' : begin Typ:=scInteger; Flags:=Flags or scDecimal or scHex or scOctal; end;
      'D' : begin Typ:=scInteger; Flags:=Flags or scDecimal; end;
      'U' : begin Typ:=scInteger; Flags:=Flags or scDecimal or scUnsigned; end;
      'X' : begin Typ:=scInteger; Flags:=Flags or scHex; end;
      'O' : begin Typ:=scInteger; Flags:=Flags or scOctal; end;
      'F','G','E' : begin Typ:=scFloat; Flags:=Flags or scDecimal; end;
      'N' : Typ:=scNspec;
      'S' : Typ:=scPChar;
         // No size specs. allowed:
      'C' : if Size=#0 then Typ:=scChar else Exit;
      'P' : if Size = #0 then begin
              Typ:=scInteger; Flags:=Flags or scHex;
            end else Exit;
      'M' : if Size=#0 then begin
              Typ:=scCurrency;
              if Format^='M' then Flags:=Flags or scFormatted;
            end else Exit;
      else begin Dec(Format); Exit; end;
    end;
    Case Typ of
      scPChar, scCharSet :
        Case Size of
          'H', 'L' : Exit; // 'H' and 'L' not allowed with strings
        end;
    end;
    Inc(Format);
  end; { With Ftype}
  Result:=FType;
end;

// ***********  DeFormat ***********************************************//

function DeFormat_core(var Buffer : PChar; BufLen: Cardinal;
                       var Format : PChar; FmtLen: Cardinal;
                       Args: array of TVarRec;
                       DecSep, ThSep : char): Cardinal;
var  // Many of these will be optimized out
  Count : cardinal;
  Index, Width : integer;
  Buf, Marker, Fmt : PChar;
  {$IFDEF DEFORMAT_EXCEPTIONS} FMarker : PChar; {$ENDIF}
  Temp : integer;
  Ptr : Pointer;
  BufEnd : PChar absolute BufLen;
  FmtEnd : PChar absolute FmtLen;
  SCR : TscRec;
  FType : integer absolute SCR;
  theSet : TCharSet;

Label BadArg, BadFormat, CopyStr, DoFloat;

  function ScanToFormat : boolean;
  begin
    ScanToFormat:=False;
    while (Fmt < FmtEnd) and (Buf < BufEnd) do begin
      case Fmt^ of
        '%' :  begin
                Inc(Fmt);
                if Fmt^='%' then  // this is "%%", check for "%" in Buf
                  If Buf^ <> '%' then Exit
                  else begin Inc(Buf); Inc(Fmt); end
                else begin
                  ScanToFormat:=True; // Start of Fmt specifier found.
                  Exit;
                end;
              end;
         #0..#32 : begin
                     while (Buf < BufEnd) and (Buf^ <=' ') do Inc(Buf);
                     while (Fmt < FmtEnd) and (Fmt^ <=' ') do Inc(Fmt);
                   end;
         else begin
           {$IFNDEF DEFORMAT_CASE_SENSITIVE}
             if Buf^ <> Fmt^ then Exit;
           {$ELSE}
             if UpCase(Buf^) <> UpCase(Fmt^) then Exit;
           {$ENDIF}
           Inc(Buf);
           Inc(Fmt);
         end;
       end;
    end; {While}
  end;

  // Returns:  -1 in case of '*' error
  //           0 on success
  //           1 in case of numerical input error
  function GetNumFields : integer;
  var Temp : cardinal;
      GotTemp, GotIndex : boolean;
  begin
    GotIndex:=False;
    Temp:=0; // not really necessary, but this will suppress compiler's warning. 
    repeat
      GotTemp:=False;
      if Fmt^='*' then begin  // Get indirect entry into Temp
        Inc(Fmt);
        If (Index <= High(Args)) and (Args[Index].VType=vtInteger) then
        begin
          Temp:=Args[Index].VInteger;
          Inc(Index);
          GotTemp:=True;
        end else begin Result:=-1; Exit; end;
      end else begin          // Get explicit numerical entry into Temp
        if Fmt^='-' then Inc(Fmt); // minus is ignored on scanning
        Temp:=0; //start simple decimal input loop
        while (Fmt^ >= '0') and (Fmt^ <= '9') do begin
          Temp:=Temp*10+Ord(Fmt^)-Ord('0');
          Inc(Fmt); GotTemp:=True;
        end;
      end;
      Case Fmt^ of
        ':' : If (not GotIndex) and GotTemp then begin
                Index:=Temp; Inc(Fmt); GotIndex:=True;
              end else begin
                Result:=1; Exit;
              end;
        '.' : begin
                If GotTemp then Width:=Temp;
                Inc(Fmt); // OK, now ignore precision in any form
                If Fmt^='*' then begin Inc(Index); Inc(Format); end
                else while (Fmt^ >= '0') and (Fmt^ <= '9') do Inc(Fmt);
                Break;
              end;
        else begin
          If GotTemp then Width:=Temp;
          Break;
        end;
      end; {Case}
    until Fmt^ <> ':';
    Result:=0;
  end;

begin
  Buf:=Buffer; Fmt:=Format; FmtEnd:=Fmt+FmtLen; BufEnd:=Buf+BufLen; Index:=0;  Result:=0; // initialization
{$IFDEF DEFORMAT_EXCEPTIONS}
try
{$ENDIF}
  while ScanToFormat do   // ScanToFormat returns False if end is reached
  with SCR do begin
    Width:=0;
    {$IFDEF DEFORMAT_EXCEPTIONS} FMarker:=Fmt-1; {$ENDIF}
    Case GetNumFields of
     -1 : BadArg : begin
                   {$IFDEF DEFORMAT_EXCEPTIONS}
                     raise EConvertError.CreateFmt(SArgumentMissing,[Copy(FMarker, 1, Fmt-FMarker+1)]);
                   {$ENDIF}
                     Break;
                   end;
      1 : BadFormat : begin
                      {$IFDEF DEFORMAT_EXCEPTIONS}
                        raise EConvertError.CreateFmt(SInvalidFormat, [Copy(FMarker, 1, Fmt-FMarker+2)]);
                      {$ENDIF}
                        Break;
                      end;
    end;
    SCR:=GetSizeType(Fmt);
    Ptr:=NIL;
    if (Ftype > 0) then begin
      if Index > High(Args) then goto BadArg else Ptr:=Args[Index].VPointer;
      if Ptr=NIL then Flags:=Flags or scNoAssign; // DeFormat treats NIL as NoAssign
    end;
    if Typ = scNSpec then begin
      Flags:=Flags or sc1000Sep;
      Typ:=scFloat;
    end;
    Case Typ of
      scPChar, scFloat, scInteger, scCurrency : // Skip blank space for these formats
        begin
          while (Buf <= BufEnd) and (Buf^ <= ' ') do Inc(Buf);
          if Buf >= BufEnd then Break;
        end;
      scCharSet : if not ParseSet(Fmt, FmtEnd, theSet) then goto BadFormat;
      scChar    : if Width = 0 then Inc(Width);
    end;
    if Width = 0 then Width:=defWidth;
    if Width > BufEnd-Buf then Width := BufEnd-Buf;  // Set maximum width
    Marker:=Buf;
    Case Typ of
      scChar    : begin
                    if FType > 0 then
                      Case Args[Index].VType of
                        vtPChar, vtPointer : Move(Buf^, Ptr^, Width);
                        else goto BadArg;
                      end;
                    Inc(Buf, Width);
                  end;
      scCharSet : begin
                    for Count:=1 to Width do if (Buf^ in theSet) then Inc(Buf) else Break;
                    goto CopyStr;
                  end;
      scPChar :   begin
                    for Count:=1 to Width do if (Buf^ > ' ') then Inc(Buf) else Break;
        CopyStr :   If (FType > 0) then
                      Case Size of   // explicit size modifier has precedence
                        'l' : SetString(AnsiString(Ptr^), Marker, Buf-Marker);
                        'h' : SetString(ShortString(Ptr^), Marker, Buf-Marker);
                        else   // No size specified, use implicit sizes
                        Case Args[Index].VType of
                          vtPointer, vtPChar, vtAnsiString :
                          begin
                            Move(Marker^, Ptr^, Buf-Marker); // this may fail on vtAnsiString!
                            PChar(Ptr)[Buf-Marker]:=#0;
                            if Args[Index].VType = vtAnsiString then PInt(PChar(Ptr)-4)^:=Buf-Marker; {SetLength}
                          end;
                          vtString : SetString(ShortString(Ptr^), Marker, Buf-Marker);
                          else goto BadArg;
                        end;
                      end;
                    end;
      scInteger : begin
                    if (FType > 0) and (Args[Index].VType <> vtPointer) then goto BadArg; {Check argument conflict}
                    if (Flags and scBaseMask) <> scOctal then Flags:=Flags and not scOctal; // No implicit octal
                    Temp:=NumScan(Buf, Width, FType, Ptr, DecSep, ThSep);
                    if Temp <= 0 then begin
                    {$IFDEF DEFORMAT_EXCEPTIONS}
                      raise EConvertError.CreateFmt(SInvalidInteger, [Copy(Marker, 0, Marker-Buf+1)]);
                    {$ENDIF}
                      Break;
                    end;
                    {$IFOPT Q+}
                    if (Temp and scOverflow) <> 0 then begin
                      raise EIntOverflow.Create(SOverflow + ' while scanning ' + Copy(Buffer,1, Buf-Buffer));
                      Break;
                    end;
                    {$ENDIF}
                  end;
      scCurrency : if (Flags and scFormatted) <> 0 then begin
                     Temp:=StrToCurrF_core(Buf, Width, Currency(Ptr^), PChar(CurrencyString),
                           CurrencyFormat, NegCurrFormat, DecSep, ThSep);
                     if Temp <= 0 then begin
                     {$IFDEF DEFORMAT_EXCEPTIONS}
                       raise EConvertError.CreateFmt(SInvalidCurrency, [Copy(Marker, 0, Marker-Buf+1)]);
                     {$ENDIF}
                       Break;
                     end;
                   end else
                     if FType >= 0 then
                       Case Args[Index].Vtype of
                         vtPointer, vtCurrency : goto doFloat;
                         else goto BadArg;
                       end;
      scFloat :   begin
                    if SizeType = scFloat then Size:='L';  // Delphi default is Extended
                    if FType >= 0 then {Check argument conflict}
                      Case Args[Index].VType of
                        vtPointer : {OK};
                        vtExtended : if (Typ <> scFloat)
                                     {$IFNDEF DELPHI110}
                                        and (SizeType <> scInt64) // before Delphi 4, Comp is floating point type
                                     {$ENDIF}
                                     then goto BadArg;
                        {$IFDEF DELPHI110}
                        vtInt64    : if (SizeType <> scInt64) then goto BadArg;
                        {$ENDIF}
                        else goto BadArg;
                      end;
        doFloat:    Temp:=NumScan(Buf, Width, FType, Ptr, DecSep, ThSep);
                    if Temp <=0 then begin
                    {$IFDEF DEFORMAT_EXCEPTIONS}
                      raise EConvertError.CreateFmt(SInvalidFloat, [Copy(Marker, 0, Marker-Buf+1)]);
                    {$ENDIF}
                      Break;
                    end;
                    {$IFOPT Q+}
                    if (Temp and scOverflow) <> 0 then begin
                      raise EOverflow.Create(SOverflow + ' while scanning ' + Copy(Buffer, 1, Buf-Buffer));
                      Break;
                    end;
                    {$ENDIF}
                  end;
      else goto BadFormat;  // scIllegal or something unsupported
    end; { Case }
    If FType > 0 then Inc(Result);
    Inc(Index);
  end; { While, With }
{$IFDEF DEFORMAT_EXCEPTIONS}
finally
{$ENDIF}
  Buffer:=Buf; Format:=Fmt; // return final positions
{$IFDEF DEFORMAT_EXCEPTIONS}
end;
{$ENDIF}
end;

// ***********  scanf ************************************************//

function scGetFType( var Fmt : PChar; var Width : cardinal)  : integer;
var Temp : integer;
    NoAssign : integer;
    Marker : PChar;
begin
  Result:=scIllegal;
  If Fmt^='*' then begin
    NoAssign:=scNoAssign shl 16;
    Inc(Fmt);
  end else NoAssign:=0;