mORMot and Open Source friends
Diff
Not logged in

Differences From Artifact [add03ba21b7301cc]:

To Artifact [6efe313e865894d9]:


177
178
179
180
181
182
183

184
185
186
187
188
189
190
.....
20871
20872
20873
20874
20875
20876
20877
20878
20879
20880
20881
20882
20883
20884
20885
.....
23617
23618
23619
23620
23621
23622
23623

23624
23625
23626
23627
23628
23629
23630
.....
23649
23650
23651
23652
23653
23654
23655






23656
23657
23658
23659
23660
23661
23662
.....
23710
23711
23712
23713
23714
23715
23716

23717
23718
23719
23720
23721
23722
23723
23724
23725
23726
23727
23728

23729

23730
23731
23732
23733
23734
23735
23736
.....
26451
26452
26453
26454
26455
26456
26457

26458
26459
26460

26461
26462
26463
26464
26465
26466
26467
.....
27011
27012
27013
27014
27015
27016
27017

27018
27019
27020
27021
27022
27023
27024
27025
27026
27027
27028
27029
27030
27031
27032
27033
27034
27035
27036





27037
27038
27039
27040
27041
27042
27043
27044
27045
27046
27047



27048
27049
27050
27051
27052
27053
27054
27055
27056
    with some speed enhancements and new associated tests
  - fixed issue in produced JSON stream using '=' instead of ':'
  - new DoubleToStr(), StrCurr64(), UnicodeBufferToString(),
    RawUnicodeToString(), FillChar(), UpperCopy255W(), GetCaptionFromEnum(),
    SortDynArrayUnicodeString(), SortDynArrayUnicodeStringI() functions

  Version 1.15

  - TSynLog now writes the elapsed time (in us) for Enter/Leave events, and
    will flush the log content to disk on any exception (for safety)
  - new sllTrace and sllWarning levels for TSynLog class
  - new TSynLog.DefaultExtension property (set to '.log' by default)
  - new TSynLogFile.LogProc[] property for customer-side method profiling,
    with LogProcSort method available for sorting the resulting array, and
    LogProcMerged property to merge the location name timing
................................................................................
  Check(IntToThousandString(-10)='-10');
  Check(IntToThousandString(-100)='-100');
  Check(IntToThousandString(-1000)='-1,000');
  Check(IntToThousandString(-10000)='-10,000');
  Check(IntToThousandString(-100000)='-100,000');
  Check(IntToThousandString(-1000000)='-1,000,000');
{$ifndef LVCL}
  DecimalSeparator := '.';
{$endif}
  for i := 1 to 10000 do begin
    j := Random(maxInt)-Random(maxInt);
    str(j,a);
    s := RawUTF8(a);
    Check(kr32(0,pointer(s),length(s))=kr32pas(pointer(s),length(s)));
    u := string(a);
................................................................................

{$ifdef USESYNTABLEVARIANT}

var
  SynTableVariantType: TCustomVariantType = nil;
  SynVariantTypes: TObjectList = nil;


function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer;
var Size: Cardinal;
    ByRef: Boolean;
    V: Variant absolute Value;
const varWord64 = 21;
begin // this code should copy parameters without any reference count handling
  FillChar(Value,sizeof(Value),0); // TVarData is expected to be bulk stack
................................................................................
      Size := sizeof(Int64);
    {$endif}
  end;
  varStrArg: begin
    Value.VType := varString;
    Value.VString := PPointer(P)^;
  end;






  varBoolean: V := PWordBool(P)^;
  varVariant: begin
    move(P^,Value,sizeof(Value));
    if not ByRef then
      Size := Sizeof(Value);
  end;
  else
................................................................................
  end;
end;

procedure VariantsDispInvoke;
asm
  call Variants.@DispInvoke;
end;


function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TCustomVariantType;
{$ifdef DELPHI6OROLDER}
var VarMgr: TVariantManager;
{$endif}
begin
  if SynVariantTypes=nil then begin
{$ifdef DELPHI6OROLDER}
    GetVariantManager(VarMgr);
    VarMgr.DispInvoke := @SynVarDispProc;
    SetVariantManager(VarMgr);
{$else}

    RedirectCode(GetAddressFromCall(@VariantsDispInvoke),@SynVarDispProc);

{$endif}
    SynVariantTypes := TObjectList.Create;
  end;
  result :=  aClass.Create; // register variant type
  SynVariantTypes.Add(result);
end;

................................................................................
    if Assigned(OnArchive) then
    if FindFirst(DestinationPath+'*'+DefaultExtension,faAnyFile,SR)=0 then
    try
      if ArchiveAfterDays<0 then
        ArchiveAfterDays := 0;
      OldTime := DateTimeToFileDate(Now-ArchiveAfterDays);
      repeat

        if (SR.Name[1]='.') or (faDirectory and SR.Attr<>0) or
           (SR.Time>OldTime) then
          continue;

        aOldLogFileName := DestinationPath+SR.Name;
        if aPath='' then begin
          aTime := FileAgeToDateTime(aOldLogFileName);
          if (aTime=0) or
             not DirectoryExists(ArchivePath+'log') and
             not CreateDir(ArchivePath+'log') then
            break;
................................................................................
    result := true;
    for i := 2 to 7 do
      if PWord(xret-i)^ and $38FF=$10FF then
        exit;
    result := false;
  end;
var st, max_stack, min_stack, depth: PtrUInt;

begin
  if fFamily.StackTraceLevel<=0 then
    exit;
  depth := fFamily.StackTraceLevel;
  if Stack=nil then // if no Stack pointer set, retrieve current one
    asm
      mov eax,ebp // push ebp; mov ebp,esp done at begin level above
      mov Stack,eax
    end;
  fWriter.AddShort(' stack trace ');
  SynLogExceptionEnabled := false; // for IsBadCodePtr
  try
    asm
      mov eax,fs:[18h]
      mov ecx,dword ptr [eax+4]
      mov max_stack,ecx
      mov ecx,dword ptr [eax+8]
      mov min_stack,ecx
    end;





    while PtrUInt(stack)<max_stack do begin
      st := stack^;
      if ((st>max_stack) or (st<min_stack)) and
         not IsBadReadPtr(pointer(st-8),12) and
         ((pByte(st-5)^=$E8) or check2(st)) then begin
        TSynMapFile.Log(fWriter,st); // will ignore any TSynLog.* methods
        dec(depth);
        if depth=0 then break;
      end;
      inc(stack);
    end;



  finally
    SynLogExceptionEnabled := true;
  end;
end;


procedure ExeVersionRetrieve(DefaultVersion: integer);
const EXE_FMT: PUTF8Char = '% % (%)';
var HostTmp, UserTmp: array[byte] of AnsiChar;







>







 







|







 







>







 







>
>
>
>
>
>







 







>












>

>







 







>



>







 







>









<
<
<
|
|
|
|
|
|
|
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
>

|







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
.....
20872
20873
20874
20875
20876
20877
20878
20879
20880
20881
20882
20883
20884
20885
20886
.....
23618
23619
23620
23621
23622
23623
23624
23625
23626
23627
23628
23629
23630
23631
23632
.....
23651
23652
23653
23654
23655
23656
23657
23658
23659
23660
23661
23662
23663
23664
23665
23666
23667
23668
23669
23670
.....
23718
23719
23720
23721
23722
23723
23724
23725
23726
23727
23728
23729
23730
23731
23732
23733
23734
23735
23736
23737
23738
23739
23740
23741
23742
23743
23744
23745
23746
23747
.....
26462
26463
26464
26465
26466
26467
26468
26469
26470
26471
26472
26473
26474
26475
26476
26477
26478
26479
26480
.....
27024
27025
27026
27027
27028
27029
27030
27031
27032
27033
27034
27035
27036
27037
27038
27039
27040



27041
27042
27043
27044
27045
27046
27047
27048
27049
27050
27051
27052
27053
27054
27055
27056
27057
27058
27059
27060
27061
27062
27063
27064
27065
27066
27067
27068
27069
27070
27071
27072
27073
27074
27075
    with some speed enhancements and new associated tests
  - fixed issue in produced JSON stream using '=' instead of ':'
  - new DoubleToStr(), StrCurr64(), UnicodeBufferToString(),
    RawUnicodeToString(), FillChar(), UpperCopy255W(), GetCaptionFromEnum(),
    SortDynArrayUnicodeString(), SortDynArrayUnicodeStringI() functions

  Version 1.15
  - unit now tested with Delphi XE2 (32 Bit)
  - TSynLog now writes the elapsed time (in us) for Enter/Leave events, and
    will flush the log content to disk on any exception (for safety)
  - new sllTrace and sllWarning levels for TSynLog class
  - new TSynLog.DefaultExtension property (set to '.log' by default)
  - new TSynLogFile.LogProc[] property for customer-side method profiling,
    with LogProcSort method available for sorting the resulting array, and
    LogProcMerged property to merge the location name timing
................................................................................
  Check(IntToThousandString(-10)='-10');
  Check(IntToThousandString(-100)='-100');
  Check(IntToThousandString(-1000)='-1,000');
  Check(IntToThousandString(-10000)='-10,000');
  Check(IntToThousandString(-100000)='-100,000');
  Check(IntToThousandString(-1000000)='-1,000,000');
{$ifndef LVCL}
  {$ifdef ISDELPHIXE2}FormatSettings.{$endif}DecimalSeparator := '.';
{$endif}
  for i := 1 to 10000 do begin
    j := Random(maxInt)-Random(maxInt);
    str(j,a);
    s := RawUTF8(a);
    Check(kr32(0,pointer(s),length(s))=kr32pas(pointer(s),length(s)));
    u := string(a);
................................................................................

{$ifdef USESYNTABLEVARIANT}

var
  SynTableVariantType: TCustomVariantType = nil;
  SynVariantTypes: TObjectList = nil;

{$ifndef ISDELPHIXE2} // Delphi XE2 just does not like our performance trick :(
function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer;
var Size: Cardinal;
    ByRef: Boolean;
    V: Variant absolute Value;
const varWord64 = 21;
begin // this code should copy parameters without any reference count handling
  FillChar(Value,sizeof(Value),0); // TVarData is expected to be bulk stack
................................................................................
      Size := sizeof(Int64);
    {$endif}
  end;
  varStrArg: begin
    Value.VType := varString;
    Value.VString := PPointer(P)^;
  end;
  {$ifdef UNICODE}
  varUString, 74: begin
    Value.VType := varString;
    Value.VUString := PPointer(P)^;
  end;
  {$endif}
  varBoolean: V := PWordBool(P)^;
  varVariant: begin
    move(P^,Value,sizeof(Value));
    if not ByRef then
      Size := Sizeof(Value);
  end;
  else
................................................................................
  end;
end;

procedure VariantsDispInvoke;
asm
  call Variants.@DispInvoke;
end;
{$endif}

function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TCustomVariantType;
{$ifdef DELPHI6OROLDER}
var VarMgr: TVariantManager;
{$endif}
begin
  if SynVariantTypes=nil then begin
{$ifdef DELPHI6OROLDER}
    GetVariantManager(VarMgr);
    VarMgr.DispInvoke := @SynVarDispProc;
    SetVariantManager(VarMgr);
{$else}
  {$ifndef ISDELPHIXE2} // Delphi XE2 just does not like our performance trick :(
    RedirectCode(GetAddressFromCall(@VariantsDispInvoke),@SynVarDispProc);
  {$endif}
{$endif}
    SynVariantTypes := TObjectList.Create;
  end;
  result :=  aClass.Create; // register variant type
  SynVariantTypes.Add(result);
end;

................................................................................
    if Assigned(OnArchive) then
    if FindFirst(DestinationPath+'*'+DefaultExtension,faAnyFile,SR)=0 then
    try
      if ArchiveAfterDays<0 then
        ArchiveAfterDays := 0;
      OldTime := DateTimeToFileDate(Now-ArchiveAfterDays);
      repeat
        {$WARN SYMBOL_DEPRECATED OFF} // for SR.Time
        if (SR.Name[1]='.') or (faDirectory and SR.Attr<>0) or
           (SR.Time>OldTime) then
          continue;
        {$WARN SYMBOL_DEPRECATED ON}
        aOldLogFileName := DestinationPath+SR.Name;
        if aPath='' then begin
          aTime := FileAgeToDateTime(aOldLogFileName);
          if (aTime=0) or
             not DirectoryExists(ArchivePath+'log') and
             not CreateDir(ArchivePath+'log') then
            break;
................................................................................
    result := true;
    for i := 2 to 7 do
      if PWord(xret-i)^ and $38FF=$10FF then
        exit;
    result := false;
  end;
var st, max_stack, min_stack, depth: PtrUInt;
    prevState: boolean;
begin
  if fFamily.StackTraceLevel<=0 then
    exit;
  depth := fFamily.StackTraceLevel;
  if Stack=nil then // if no Stack pointer set, retrieve current one
    asm
      mov eax,ebp // push ebp; mov ebp,esp done at begin level above
      mov Stack,eax
    end;



  asm
    mov eax,fs:[18h]
    mov ecx,dword ptr [eax+4]
    mov max_stack,ecx
    mov ecx,dword ptr [eax+8]
    mov min_stack,ecx
  end;
  fWriter.AddShort(' stack trace ');
  prevState := SynLogExceptionEnabled;
  SynLogExceptionEnabled := false; // for IsBadCodePtr
  try
    try
      while (PtrUInt(stack)<max_stack) do begin
        st := stack^;
        if ((st>max_stack) or (st<min_stack)) and
           not IsBadReadPtr(pointer(st-8),12) and
           ((pByte(st-5)^=$E8) or check2(st)) then begin
          TSynMapFile.Log(fWriter,st); // will ignore any TSynLog.* methods
          dec(depth);
          if depth=0 then break;
        end;
        inc(stack);
      end;
    except
      // just ignore any access violation here
    end;
  finally
    SynLogExceptionEnabled := prevState;
  end;
end;


procedure ExeVersionRetrieve(DefaultVersion: integer);
const EXE_FMT: PUTF8Char = '% % (%)';
var HostTmp, UserTmp: array[byte] of AnsiChar;