View Issue Details

IDProjectCategoryView StatusLast Update
0032098FPCRTLpublic2017-07-08 21:55
ReporterskywebAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionfixed 
PlatformallOSallOS Versionall
Product VersionProduct Build 
Target Version3.2.0Fixed in Version3.1.1 
Summary0032098: IntStrToDate() too lax with date string format
DescriptionI found that TryStrToDate() and StrToDate() can convert many forms of text to date value, some results is not right, and some forms should not be valid date form. like "002017-00002-000023", "00231232-0001-031", etc.
Steps To Reproduce{ try this program }
program t1;

uses sysutils;

var
  myfs: TFormatSettings;

procedure test(s: string);
var
  dt: TDate;
begin
  dt := StrToDate(s, myfs);
  writeln(Format('%-30s => %s', ['StrToDate(''' + s + ''')', DateToStr(dt, myfs)]));
end;

begin
  myfs := DefaultFormatSettings;
  myfs.DateSeparator := '-';
  myfs.ShortDateFormat := 'yyyy-mm-dd';
  test('002017-01-01');
  test('2017-0001-001');
  test('002017');
  test('0020170623');
  test('0017');
  test('003');
  test('3');
  test('0010-3');
  test('0011213123-002-0003');
  test('0011213123-0002535-0003556');
end.

Additional InformationThe problem located at dati.inc, function IntStrToDate(), line 448: "val(s1, values[n], c);", and line 375 "s1:string[4];"

Because s1 is a 4 char string, so "s1 := '00231232';" equals "s1 := '0023';".
And function val() do not care about length of s1, so "0002" and "2" is the same to val().

in my opinion, '3' and '03' should be a valid date text, but '003', '0003', '00034' is not.

I have made a alternative IntStrToDate() and it's testing code, see the attachment.
TagsNo tags attached.
Fixed in Revision36687
FPCOldBugId
FPCTarget
Attached Files
  • dt.pas (6,923 bytes)
    program dt;
    {$mode delphi}
    uses SysUtils;
    
    function IntStrToDate(Out ErrorMsg : AnsiString; const S: PChar; Len : integer; const useformat : string; const defs:TFormatSettings; separator : char = #0): TDateTime;
    type
      TDigitValues = array[0..3] of string;
      procedure DetermineYMDOrder(out yp, mp, dp: Byte);
      var
        df: string;
        i, which: integer;
      begin
        which := 0;
        yp := 0;
        mp := 0;
        dp := 0;
        df := UpperCase(useFormat);
        for i := 1 to Length(df) do
          case df[i] of
            'Y' :
              if yp = 0 then
              begin
                inc(which);
                yp := which;
              end;
            'M' :
              if mp = 0 then
              begin
                inc(which);
                mp := which;
              end;
            'D' :
              if dp = 0 then
              begin
                inc(which);
                dp := which;
              end;
          end;
      end;
      function ParseDigitValues(out strs: TDigitValues; out parts: integer): boolean;
      type
        TParseState = (psInit, psNumber, psSeparator);
      var
        p, q, r: PChar;
        state: TParseState;
        l: integer;
      begin
        parts := 0;
        state := psInit;
        Result := false;
        p := S;
        q := @S[Len - 1];
        // Trim right
        while (q > p) and (q^ in [' ',#8,#9,#10,#12,#13]) do dec(q);
        // Parse int values
        while p <= q do
        begin
          if p^ in ['0'..'9'] then
          begin
            if state <> psNumber then
            begin
              state := psNumber;
              r := p;
            end;
          end
          else if p^ = Separator then
          begin
            if state <> psNumber then exit;
            state := psSeparator;
            Inc(parts);
            if parts > 3 then exit;
            l := (p-r) div sizeof(Char);
            Assert(l > 0);
            SetLength(strs[parts], l);
            Move(r^, strs[parts][1], l);
          end
          { space can be part of the shortdateformat, and is defaultly in slovak
            windows, therefor it shouldn't be taken as separator (unless so specified)
            and ignored }
          else if p^ <> ' ' then exit;
          Inc(p);
        end;
        if r < p then
        begin
          Inc(parts);
          l := (p-r) div sizeof(Char);
          SetLength(strs[parts], l);
          Move(r^, strs[parts][1], l);
        end;
        Result := true;
      end;
      function GetIntValue(const str: string; maxlen: integer): integer;
      var
        ec: word; 
      begin
        if Length(str) > maxlen then Result := -1
        else begin
          Val(str, Result, ec);
          if ec <> 0 then Result := -1;
        end;
      end;
    var
      d, m, y, ly: word;
      dp, mp, yp: Byte;
      parts: integer;
      strs: TDigitValues;
      LocalTime: TSystemTime;
      YearMoreThenTwoDigits: boolean;
    begin
      ErrorMsg := 'Invalid date ''' + s + '''';
      Result := 0;
      YearMoreThenTwoDigits := False;
      if separator = #0 then separator := defs.DateSeparator;
      DetermineYMDOrder(yp, mp, dp);
      if not ParseDigitValues(strs, parts) then exit;
      // Set YMD value
      if parts = 3 then
      begin
        YearMoreThenTwoDigits := Length(strs[yp]) > 2;
        y := GetIntValue(strs[yp], 4);
        m := GetIntValue(strs[mp], 2);
        d := GetIntValue(strs[dp], 2);
      end
      else begin
        getLocalTime(LocalTime);
        y := LocalTime.Year;
        if parts < 2 then
        begin
          m := LocalTime.Month;
          d := GetIntValue(strs[1], 2);
        end
        else if dp < mp then
        begin
          d := GetIntValue(strs[1], 2);
          m := GetIntValue(strs[2], 2);
        end
        else begin
          m := GetIntValue(strs[1], 2);
          d := GetIntValue(strs[2], 2);
        end;
      end;
      // deal with two digit year value
      if (y < 100) and not YearMoreThenTwoDigits then
      begin
        ly := LocalTime.Year - defs.TwoDigitYearCenturyWindow;
        Inc(Y, ly div 100 * 100);
        if (defs.TwoDigitYearCenturyWindow > 0) and (Y < ly) then
          Inc(Y, 100);
      end;
      if TryEncodeDate(y, m, d, result) then errormsg := '';
    end;
    
    function TryStrToDate(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
    Var
      Msg : Ansistring;
    
    begin
      Result:=Length(S)<>0;
      If Result then
        begin
          Value:=IntStrToDate(Msg,PChar(S),Length(S),FormatSettings.ShortDateFormat,FormatSettings,#0);
          Result:=(Msg='');
        end;
    end;
    
    var
      myfs: TFormatSettings;
    
    procedure test_mine(const TestValue: string; WantBool: boolean; const WantValue: string = '');
    var
      dt: TDate;
      ResultBool: boolean;
      ResultValue: string;
    begin
      ResultBool := TryStrToDate(TestValue, dt, myfs);
      if ResultBool then
      begin
        ResultValue := DateToStr(dt, myfs);
        Write('Test ''' + TestValue + ''', got ''' + ResultValue + ''' => ');
        if ResultBool = WantBool then Writeln('OK!')
        else Writeln('Failed!');
      end
      else begin
        Write('Test ''' + TestValue + ''', got FALSE');
        if ResultBool = WantBool then Writeln(' => OK!')
        else Writeln(', but want ''', WantValue, ''' => Failed!');
      end;
    end;
    
    procedure test_old(const TestValue: string; WantBool: boolean; const WantValue: string = '');
    var
      dt: TDate;
      ResultBool: boolean;
      ResultValue: string;
    begin
      ResultBool := SysUtils.TryStrToDate(TestValue, dt, myfs);
      if ResultBool then
      begin
        ResultValue := DateToStr(dt, myfs);
        Write('Test ''' + TestValue + ''', got ''' + ResultValue + ''' => ');
        if ResultBool = WantBool then Writeln('OK!')
        else Writeln('Failed!');
      end
      else begin
        Write('Test ''' + TestValue + ''', got FALSE');
        if ResultBool = WantBool then Writeln(' => OK!')
        else Writeln(', but want ''', WantValue, ''' => Failed!');
      end;
    end;
    
    begin
      myfs := DefaultFormatSettings; 
      myfs.DateSeparator := '-';
      myfs.ShortDateFormat := 'yyyy-mm-dd';
      Writeln('Test SysUtils.TryStrToDate() ...');
      Writeln('--------------------------------------------------');
      test_old('2017-01-01', true, '2017-01-01');
      test_old('01-01', true, '2017-01-01');
      test_old('01', true, '2017-07-01');
      test_old('1', true, '2017-07-01');
      test_old('002017-01-01', false);
      test_old('2017-0001-001', false);
      test_old('002017', false);
      test_old('0020170623', false);
      test_old('0017', false);
      test_old('003', false);
      test_old('3', true, '2017-07-03');
      test_old('0010-3', false);
      test_old('0011213123-002-0003', false);
      test_old('0011213123-0002535-0003556', false);
      Writeln('--------------------------------------------------');
      Writeln;
    
      Writeln('Test reconstructed TryStrToDate() ...');
      Writeln('--------------------------------------------------');
      test_mine('2017-01-01', true, '2017-01-01');
      test_mine('01-01', true, '2017-01-01');
      test_mine('01', true, '2017-07-01');
      test_mine('1', true, '2017-07-01');
      test_mine('002017-01-01', false);
      test_mine('2017-0001-001', false);
      test_mine('002017', false);
      test_mine('0020170623', false);
      test_mine('0017', false);
      test_mine('003', false);
      test_mine('3', true, '2017-07-03');
      test_mine('0010-3', false);
      test_mine('0011213123-002-0003', false);
      test_mine('0011213123-0002535-0003556', false);
      Writeln('--------------------------------------------------');
    end.
    
    
    dt.pas (6,923 bytes)

Activities

skyweb

2017-07-03 10:21

reporter  

dt.pas (6,923 bytes)
program dt;
{$mode delphi}
uses SysUtils;

function IntStrToDate(Out ErrorMsg : AnsiString; const S: PChar; Len : integer; const useformat : string; const defs:TFormatSettings; separator : char = #0): TDateTime;
type
  TDigitValues = array[0..3] of string;
  procedure DetermineYMDOrder(out yp, mp, dp: Byte);
  var
    df: string;
    i, which: integer;
  begin
    which := 0;
    yp := 0;
    mp := 0;
    dp := 0;
    df := UpperCase(useFormat);
    for i := 1 to Length(df) do
      case df[i] of
        'Y' :
          if yp = 0 then
          begin
            inc(which);
            yp := which;
          end;
        'M' :
          if mp = 0 then
          begin
            inc(which);
            mp := which;
          end;
        'D' :
          if dp = 0 then
          begin
            inc(which);
            dp := which;
          end;
      end;
  end;
  function ParseDigitValues(out strs: TDigitValues; out parts: integer): boolean;
  type
    TParseState = (psInit, psNumber, psSeparator);
  var
    p, q, r: PChar;
    state: TParseState;
    l: integer;
  begin
    parts := 0;
    state := psInit;
    Result := false;
    p := S;
    q := @S[Len - 1];
    // Trim right
    while (q > p) and (q^ in [' ',#8,#9,#10,#12,#13]) do dec(q);
    // Parse int values
    while p <= q do
    begin
      if p^ in ['0'..'9'] then
      begin
        if state <> psNumber then
        begin
          state := psNumber;
          r := p;
        end;
      end
      else if p^ = Separator then
      begin
        if state <> psNumber then exit;
        state := psSeparator;
        Inc(parts);
        if parts > 3 then exit;
        l := (p-r) div sizeof(Char);
        Assert(l > 0);
        SetLength(strs[parts], l);
        Move(r^, strs[parts][1], l);
      end
      { space can be part of the shortdateformat, and is defaultly in slovak
        windows, therefor it shouldn't be taken as separator (unless so specified)
        and ignored }
      else if p^ <> ' ' then exit;
      Inc(p);
    end;
    if r < p then
    begin
      Inc(parts);
      l := (p-r) div sizeof(Char);
      SetLength(strs[parts], l);
      Move(r^, strs[parts][1], l);
    end;
    Result := true;
  end;
  function GetIntValue(const str: string; maxlen: integer): integer;
  var
    ec: word; 
  begin
    if Length(str) > maxlen then Result := -1
    else begin
      Val(str, Result, ec);
      if ec <> 0 then Result := -1;
    end;
  end;
var
  d, m, y, ly: word;
  dp, mp, yp: Byte;
  parts: integer;
  strs: TDigitValues;
  LocalTime: TSystemTime;
  YearMoreThenTwoDigits: boolean;
begin
  ErrorMsg := 'Invalid date ''' + s + '''';
  Result := 0;
  YearMoreThenTwoDigits := False;
  if separator = #0 then separator := defs.DateSeparator;
  DetermineYMDOrder(yp, mp, dp);
  if not ParseDigitValues(strs, parts) then exit;
  // Set YMD value
  if parts = 3 then
  begin
    YearMoreThenTwoDigits := Length(strs[yp]) > 2;
    y := GetIntValue(strs[yp], 4);
    m := GetIntValue(strs[mp], 2);
    d := GetIntValue(strs[dp], 2);
  end
  else begin
    getLocalTime(LocalTime);
    y := LocalTime.Year;
    if parts < 2 then
    begin
      m := LocalTime.Month;
      d := GetIntValue(strs[1], 2);
    end
    else if dp < mp then
    begin
      d := GetIntValue(strs[1], 2);
      m := GetIntValue(strs[2], 2);
    end
    else begin
      m := GetIntValue(strs[1], 2);
      d := GetIntValue(strs[2], 2);
    end;
  end;
  // deal with two digit year value
  if (y < 100) and not YearMoreThenTwoDigits then
  begin
    ly := LocalTime.Year - defs.TwoDigitYearCenturyWindow;
    Inc(Y, ly div 100 * 100);
    if (defs.TwoDigitYearCenturyWindow > 0) and (Y < ly) then
      Inc(Y, 100);
  end;
  if TryEncodeDate(y, m, d, result) then errormsg := '';
end;

function TryStrToDate(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
Var
  Msg : Ansistring;

begin
  Result:=Length(S)<>0;
  If Result then
    begin
      Value:=IntStrToDate(Msg,PChar(S),Length(S),FormatSettings.ShortDateFormat,FormatSettings,#0);
      Result:=(Msg='');
    end;
end;

var
  myfs: TFormatSettings;

procedure test_mine(const TestValue: string; WantBool: boolean; const WantValue: string = '');
var
  dt: TDate;
  ResultBool: boolean;
  ResultValue: string;
begin
  ResultBool := TryStrToDate(TestValue, dt, myfs);
  if ResultBool then
  begin
    ResultValue := DateToStr(dt, myfs);
    Write('Test ''' + TestValue + ''', got ''' + ResultValue + ''' => ');
    if ResultBool = WantBool then Writeln('OK!')
    else Writeln('Failed!');
  end
  else begin
    Write('Test ''' + TestValue + ''', got FALSE');
    if ResultBool = WantBool then Writeln(' => OK!')
    else Writeln(', but want ''', WantValue, ''' => Failed!');
  end;
end;

procedure test_old(const TestValue: string; WantBool: boolean; const WantValue: string = '');
var
  dt: TDate;
  ResultBool: boolean;
  ResultValue: string;
begin
  ResultBool := SysUtils.TryStrToDate(TestValue, dt, myfs);
  if ResultBool then
  begin
    ResultValue := DateToStr(dt, myfs);
    Write('Test ''' + TestValue + ''', got ''' + ResultValue + ''' => ');
    if ResultBool = WantBool then Writeln('OK!')
    else Writeln('Failed!');
  end
  else begin
    Write('Test ''' + TestValue + ''', got FALSE');
    if ResultBool = WantBool then Writeln(' => OK!')
    else Writeln(', but want ''', WantValue, ''' => Failed!');
  end;
end;

begin
  myfs := DefaultFormatSettings; 
  myfs.DateSeparator := '-';
  myfs.ShortDateFormat := 'yyyy-mm-dd';
  Writeln('Test SysUtils.TryStrToDate() ...');
  Writeln('--------------------------------------------------');
  test_old('2017-01-01', true, '2017-01-01');
  test_old('01-01', true, '2017-01-01');
  test_old('01', true, '2017-07-01');
  test_old('1', true, '2017-07-01');
  test_old('002017-01-01', false);
  test_old('2017-0001-001', false);
  test_old('002017', false);
  test_old('0020170623', false);
  test_old('0017', false);
  test_old('003', false);
  test_old('3', true, '2017-07-03');
  test_old('0010-3', false);
  test_old('0011213123-002-0003', false);
  test_old('0011213123-0002535-0003556', false);
  Writeln('--------------------------------------------------');
  Writeln;

  Writeln('Test reconstructed TryStrToDate() ...');
  Writeln('--------------------------------------------------');
  test_mine('2017-01-01', true, '2017-01-01');
  test_mine('01-01', true, '2017-01-01');
  test_mine('01', true, '2017-07-01');
  test_mine('1', true, '2017-07-01');
  test_mine('002017-01-01', false);
  test_mine('2017-0001-001', false);
  test_mine('002017', false);
  test_mine('0020170623', false);
  test_mine('0017', false);
  test_mine('003', false);
  test_mine('3', true, '2017-07-03');
  test_mine('0010-3', false);
  test_mine('0011213123-002-0003', false);
  test_mine('0011213123-0002535-0003556', false);
  Writeln('--------------------------------------------------');
end.

dt.pas (6,923 bytes)

Michael Van Canneyt

2017-07-03 10:47

administrator   ~0101464

Be aware that strtodate does not enforce the datetime format.
The datetime format is only used to determine the order of the day month year parts. For the rest, only numbers are needed.

If you want more strict checking, you can alwas use scandatetime from the dateutils unit.

I will check how Delphi behaves for the various cases.

Michael Van Canneyt

2017-07-08 21:55

administrator   ~0101622

I checked what delphi does, and what FPC is supposed to do.

Delphi doesn't care about the number of digits:
0002017
002017
02017
All amount to 2017. Same for months, days.

FPC was extended to allow to specify 1 number: the day of the current month.

Combining these logics, all that needs to be done is to fix out-of-range numbers.

I did that, and the following program now works as designed:
program dt;
{$mode delphi}
uses SysUtils;

var
  myfs: TFormatSettings;

procedure test_old(const TestValue: string; WantBool: boolean; const WantValue: string = '');
var
  dt: TDate;
  ResultBool: boolean;
  ResultValue: string;
begin
  ResultBool := SysUtils.TryStrToDate(TestValue, dt, myfs);
  if ResultBool then
  begin
    ResultValue := DateToStr(dt, myfs);
    Write('Test ''' + TestValue + ''', got ''' + ResultValue + ''' => ');
    if ResultBool = WantBool then Writeln('OK!')
    else Writeln('Failed!');
  end
  else begin
    Write('Test ''' + TestValue + ''', got FALSE');
    if ResultBool = WantBool then Writeln(' => OK!')
    else Writeln(', but want ''', WantValue, ''' => Failed!');
  end;
end;

begin
  myfs := DefaultFormatSettings;
  myfs.DateSeparator := '-';
  myfs.ShortDateFormat := 'yyyy-mm-dd';
  Writeln('Test SysUtils.TryStrToDate() ...');
  Writeln('--------------------------------------------------');
  test_old('2017-01-01', true, '2017-01-01');
  test_old('01-01', true, '2017-01-01');
  test_old('01', true, '2017-07-01');
  test_old('1', true, '2017-07-01');
  test_old('002017-01-01', true, '2017-01-01');
  test_old('2017-0001-001', true,'2017-01-01');
  test_old('002017', False);
  test_old('0020170623', False);
  test_old('0017', True,'2017-07-17');
  test_old('003', True,'2017-07-03');
  test_old('3', true, '2017-07-03');
  test_old('0010-3', true,'2017-10-03');
  test_old('0011213123-002-0003', false);
  test_old('0011213123-0002535-0003556', false);
  Writeln('--------------------------------------------------');
  Writeln;
end.

Issue History

Date Modified Username Field Change
2017-07-03 10:21 skyweb New Issue
2017-07-03 10:21 skyweb File Added: dt.pas
2017-07-03 10:45 Michael Van Canneyt Assigned To => Michael Van Canneyt
2017-07-03 10:45 Michael Van Canneyt Status new => assigned
2017-07-03 10:47 Michael Van Canneyt Note Added: 0101464
2017-07-08 21:55 Michael Van Canneyt Fixed in Revision => 36687
2017-07-08 21:55 Michael Van Canneyt Note Added: 0101622
2017-07-08 21:55 Michael Van Canneyt Status assigned => resolved
2017-07-08 21:55 Michael Van Canneyt Fixed in Version => 3.1.1
2017-07-08 21:55 Michael Van Canneyt Resolution open => fixed
2017-07-08 21:55 Michael Van Canneyt Target Version => 3.2.0