stdfuncs.pas

FIBPlus is a component suite intended for work with InterBase. It is direct, fast and flexible Inter

  begin
    if not FTr.Suspended then
      TTimeThread(FTr).DoSuspend;

    TTimeThread(FTr).FInt := FInterval;
  end;
end;

{End SVD}
{$ENDIF}

procedure StreamToVariantArray(Stream:TMemoryStream; var Value : Variant);
var
  i : integer;
begin
  for i := 0 to Stream.Size - 1 do
   PByte(LongInt(TVarData(Value).VArray^.Data)+i)^ := PByte(LongInt(Stream.Memory)+i)^ ;
end;

procedure StreamToVariant(Stream:TMemoryStream; var Value : Variant);
var
  i : integer;
  {$IFDEF D6+}
   vt  :TVarType;
  {$ELSE}
   vt  :Integer;
  {$ENDIF}
begin
 VarClear(Value);
 if Stream.Size > 0 then
 begin
  Stream.Position:=0;
  vt:=varByte;
  Value := VarArrayCreate([0, Stream.Size-1],vt);
  for i := 0 to Stream.Size - 1 do
   PByte(LongInt(TVarData(Value).VArray^.Data)+i)^ := PByte(LongInt(Stream.Memory)+i)^ ;
 end;
end;

function VariantToStream(Value : Variant;Stream:TStream): integer; {Length of Stream}
var
    B : TVarArrayBound;
    BufSize: Integer;
begin
  Result := 0;
  if not VarIsArray(Value) then
   Exit;
  if not Assigned(Stream) then
   Exit;
  if TVarData(Value).VArray <> nil then
   begin
     B := TVarData(Value).VArray^.Bounds[0];
     if B.ElementCount > 0 then
     begin
      BufSize:=B.ElementCount*TVarData(Value).VArray^.ElementSize;
      Stream.Size:=BufSize;
      Stream.Position:=0;
      Stream.Write(TVarData(Value).VArray^.Data^, BufSize );
      Result := Stream.Size;
     end;
   end;
end;


function  StringIsDateTimeDefValue(const s:string):boolean;
begin
  Result := False;
  if Length(s) > 0 then
  case s[1] of
    'C': Result:=(s='CURRENT_TIME') or (s='CURRENT_TIMESTAMP') or (s='CURRENT_DATE');
    'N': Result:=(s='NULL') or (s='NOW');
    'T': Result:=(s='TODAY') or (s='TOMORROW'); 
    'Y': Result:=(s='YESTERDAY');
  end;
end;

{$IFNDEF D6+}

resourcestring
  SCannotCreateDir = 'Unable to create directory';

{$EXTERNALSYM CoCreateGuid}
function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';

function CreateGUID(out Guid: TGUID): HResult;
begin
  Result := CoCreateGuid(Guid);
end;
{$ENDIF}

type THackDS=class(TDataSet);


function FieldOldValAsString(Field:TField;SQLFormat:boolean):string;
var
    OldState:TDataSetState;
begin
  OldState:=Field.DataSet.State;
  try
    THackDS(Field.DataSet).SetTempState(dsOldValue);
    Result:=Field.AsString;
  finally
    THackDS(Field.DataSet).RestoreState(OldState);
  end;
  if SQLFormat and (DecimalSeparator<>'.') then
   ReplaceStr(Result,DecimalSeparator,'.')
end;


function GetBCDFieldData(Field:TField;OldVal:boolean; var BCD:TBcd):boolean;
var
    OldState:TDataSetState;
begin
  OldState:=Field.DataSet.State;
  with THackDS(Field.DataSet) do
  try
    if OldVal and (OldState<>dsOldValue) then
     SetTempState(dsOldValue);
    Result:=GetFieldData(Field,@Bcd);
  finally
    if OldVal and (OldState<>dsOldValue) then
     RestoreState(OldState);
  end;
end;


function InternalBCDFieldAsString(Field:TField;OldVal,SQLFormat:boolean):variant;
var
    Bcd :TBcd;
begin
  if GetBCDFieldData(Field,OldVal,Bcd) then
  begin
     if SQLFormat then
      Result:=BCDToSQLStr(BCD)
     else
      Result:=BCDToStr(BCD);
  end
  else
  begin
     Result:=UnAssigned;
  end;
end;

function BCDFieldAsSQLString(Field:TField;OldVal:boolean):variant;
begin
 Result:= InternalBCDFieldAsString(Field,OldVal,true)
end;

function BCDFieldAsString(Field:TField;OldVal:boolean):variant;
begin
 Result:= InternalBCDFieldAsString(Field,OldVal,false)
end;

//
function RoundExtend(Value: Extended;Decimals:integer): Extended;
begin
 Result:=
  System.Int(Value)+Round(Frac(Value)*E10[Decimals])/E10[Decimals];
end;

function TimeStamp(const aDate,aTime:integer):TTimeStamp;
begin
  with Result do
  begin
    Time:=aTime;
    Date:=aDate;
  end;
end;

function HookTimeStampToMSecs(const TimeStamp:TTimeStamp): Int64;
var t:TTimeStamp;
    c:Comp;
begin
  if TimeStamp.Date=0 then
  begin
   t.Date:=1;
   t.Time:=TimeStamp.Time;
   c:=TimeStampToMSecs(t)-86400000;
  end
  else
   c:=TimeStampToMSecs(TimeStamp);
  Result:=PInt64(@c)^
end;


function HookTimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;
var
 t:TTimeStamp;
begin
 if TimeStamp.Date=0 then
 begin
  t.Date:=1;
  t.Time:=TimeStamp.Time;
  Result:=TimeStampToDateTime(t)-1;
 end
 else
  Result:=TimeStampToDateTime(TimeStamp)
end;

function  IBStrToTime(const Str:string):TDateTime;
var
 t:TTimeStamp;
begin
  Result:=StrToTime(Str);
  t:=DateTimeToTimeStamp(Result);
  t.Date:=0;
  Result:=HookTimeStampToDateTime(t);
end;


function IntDateToDateTime(aDate:integer):TDateTime;
var
 t:TTimeStamp;
begin
  t.Date:=aDate;
  t.Time:=0;
  Result:=HookTimeStampToDateTime(t);
end;

function CmpFullName(cmp:TComponent):string;
begin
 result:='';
 while cmp<>nil do
 with cmp do
 begin
  if Name<>'' then
  if Result='' then
   result:=Name
  else
   result:=Name+'.'+Result;
  cmp:=Owner;
 end;
end;

function CmpInLoadedState(Cmp:TComponent):boolean;
var tmpCmp       :TComponent;
begin
    tmpCmp       :=Cmp;
    while   ((tmpCmp<>nil) and  not (csLoading in tmpCmp.ComponentState))  do
    begin
     tmpCmp:=tmpCmp.Owner;
    end;
    Result:=tmpCmp<>nil;
end;

procedure FullClearStrings(aStrings:TStrings);
var
  j: Integer;
begin
 with aStrings do
 for j := 0 to Pred(aStrings.Count) do
 begin
   if Objects[j]<>nil then Objects[j].Free;
 end;
  aStrings.Clear;
end;


function Degree10(Degree:integer):Extended;
begin
  Result:=E10[Degree]
end;

function  ExtPrecision(Value:Extended) :integer;
var
  L, H, I: Integer;
  c:comp;
  a:comp;
begin
  L := 0;
  H := 18;
  a := Abs(Int(Value));
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := E10[I]-a;
    if C < 0 then
     L := I + 1
    else
    begin
      H := I - 1;
      if C = 0 then
      begin
        L := I+1;
        Break
      end;
    end;
  end;
  Result:=L
end;

// Comp type stuff


function ExtendedToBCD(const Value:Extended;NeedScale:integer):TBCD;
var
//   Pr:Integer;
   c:Comp;
begin
//   Pr:=ExtPrecision(Value);
   c:=Value*E10[NeedScale];
   Int64ToBCD(PInt64(@C)^,NeedScale,Result);
end;

function  Int64ToBCD(Value: Int64;Scale:integer; var BCD: TBcd ): Boolean;
var
 c:Currency;
begin
  c:=Value/1E4;
  Result:= CurrToBCD(c,BCD);
  with BCD do
  begin
   if Value<0 then
    SignSpecialPlaces:=128
   else
    SignSpecialPlaces:=0;
   SignSpecialPlaces :=Scale+SignSpecialPlaces;
  end;
end;



function  BCDToCompWithScale(BCD: TBcd; var Value: Int64;var Scale:byte): Boolean;
var Sign:integer;
    c:Currency;
begin
 with BCD do
 begin
  if Precision=0 then
  begin
   Result:=true;
   Value:=0;
   Exit;
  end;
  if SignSpecialPlaces>=128 then
  begin
   Sign:=-1;
   Scale:=SignSpecialPlaces-128;
  end
  else
  begin
   Sign :=1 ;
   Scale:=SignSpecialPlaces;
  end;
  if Scale>=64 then
  begin
  // null
   Result:=true;
   Value:=0;
   Exit;
  end;
  SignSpecialPlaces:=4;
 end;
 Result:=BCDToCurr(BCD,C);
 if Result then
  Value :=Sign*PInt64(@C)^;
end;


function  BCDToSQLStr(BCD: TBcd): String;
var
   pd:integer;
begin
 Result:=BcdToStr(BCD);
 if DecimalSeparator<>'.' then
 begin
   pd:=PosCh(DecimalSeparator,Result);
   if pd>0 then
    Result[pd]:='.';
 end;
end;

const
    ZeroStr='000000000000000000';

{$IFDEF D6+}

{$IFNDEF D9+}
function RoundAt(const Value: string; Position: SmallInt): string;

  Procedure RoundChar(const PrevChar: SmallInt; var Carry: Boolean);
  begin
    if Result[PrevChar] in ['0' .. '9'] then
    begin
      if Result[PrevChar] = '9' then
      begin
        Result[PrevChar] := '0';
        Carry := True;
      end else
      begin
        Result[PrevChar] := Char(Byte(Result[PrevChar]) + 1);
        Carry := False;
      end;
    end;
  end;

var
  C, Dot: Char;
  PrevChar, I, DecPos, DecDigits: SmallInt;
  Carry: Boolean;
  Neg: string;
begin
  Dot := DecimalSeparator;
  if Value[1] = '-' then
  begin
    Result := FastCopy(Value, 2, MaxInt);
    Neg := '-';
  end else
  begin
    Result := Value;
    Neg := '';
  end;
  DecPos := Pos(Dot, Result);
  if DecPos > 0 then
    DecDigits := Length(Result) - DecPos
  else
    DecDigits := 0;
  if (DecPos = 0) or (DecDigits <= Position) then
    { nothing to round }
  begin
    Result := Value;
    Exit;
  end;
  if Result[DecPos + Position + 1] < '5' then
  begin
    { no possible rounding required }
    if Position = 0 then
      Result := Neg + Copy(Result, 1, DecPos + Position -1)
    else
      Result := Neg + Copy(Result, 1, DecPos + Position);
  end else
  begin
    Carry := False;
    PrevChar := 1;
    for I := DecPos + DecDigits downto (DecPos + 1 + Position) do
    begin
      C := Result[I];
      PrevChar := I-1;
      if Result[PrevChar] = Dot then
      begin
        Dec(PrevChar);
        Dec(Position);
      end;
      if (Byte(C) >= 53) or Carry then { if '5' or greater }
        RoundChar(PrevChar, Carry);
    end;
    while Carry do
    begin
      if PrevChar >= DecPos then
        Dec(Position);
      Dec(PrevChar);
      if PrevChar = 0 then
        break;
      if Result[PrevChar] <> Dot then
        RoundChar(PrevChar, Carry);
    end;
    if Carry then
      Result := Neg + '1' + Copy(Result, 1, DecPos + Position)
    else
      Result := Neg + Copy(Result, 1, DecPos + Position);
  end;
end;
{$ENDIF}

{$WARNINGS OFF}
function IsZero(const Str:string):boolean;
var
  i:integer;
begin
 Result:=False;
 for i:=1 to Length(Str) do
 begin
   Result:=Str[i] in ['0',DecimalSeparator];
   if not Result then
    Exit;
 end;
end;

function  FormatNumericString(const Format,Source: string; OneSectionFormat:boolean=False ): string;
type
   TPosType=(pBegin,pBeforeDecimalSep,pAfterDecimalSep,pEnd);
   TLiteral=record
     lBody:string;
     lPos :integer;
     lPosType:TPosType;
   end;
var
    L,i:integer;
    NeedDecimalCount:integer;
    CanHaveDecimalCount:integer;
    PosDecSepInFormat:integer;
    PosDecSepInString:integer;
    vLiterals:array of TLiteral;
const
  cFormatChars = ['#', '0', ',', '.'];

begin
 if Length(Source) = 0 then
 begin
  Result:='';
  Exit;
 end;

 if not OneSectionFormat then
 begin
  i:=PosCh(';',Format);
  if i>0 then
  begin
    case  Source[1]  of
    '+','1'..'9':
     Result:=FormatNumericString(FastCopy(Format,1,i-1),Source, True);
    else
     L:=PosCh(';',FastCopy(Format,i+1,MaxInt));
     case Source[1] of
      '0':
{       if L=0 then
        Result:=FormatNumericString(FastCopy(Format,1,i-1),Source, True)
       else

        Result:=FormatNumericString(FastCopy(Format,L+i+1,MaxInt),Source, True);
}
       if (L=0) or not IsZero(Source) then
        Result:=FormatNumericString(FastCopy(Format,1,i-1),Source, True)
       else
        Result:=FormatNumericString(FastCopy(Format,L+i+1,MaxInt),Source, True)
     else
       if L=0 then
         Result:=FormatNumericString(FastCopy(Format,i+1,MaxInt),Source, True)
       else
         Result:=FormatNumericString(FastCopy(Format,i+1,L-1),Source, True)
     end;
    end;
    Exit;
  end;
 end;


 Result:=Source;
 L:=Length(Format);
 if L>0 then
 begin
   while (L>0) and (Format[L] in [#9,' ',';']) do
    Dec(L);
   if L=0 then
   begin
    Result := '';
    Exit;
   end;
   if not (Format[L] in cFormatChars) then
   begin
     SetLength(vLiterals,1);
     vLiterals[0].lBody:='';
     vLiterals[0].lPosType:=pEnd;
     i:=L;
     while (i>0) and not (Format[i] in cFormatChars) do
     begin
       Dec(i);
     end;
     if i=0 then
     begin
        Result:=FastCopy(Format,i+1,L-i);
        Exit;
     end
     else
      vLiterals[0].lBody:=FastCopy(Format,i+1,L-i);
   end;

   i:=1;
   if (i<L) and not (Format[1] in cFormatChars) then
   begin
    SetLength(vLiterals,2);
    vLiterals[1].lBody:='';
    vLiterals[1].lPosType:=pBegin;
    while (i<L) and not (Format[i] in cFormatChars) do
     Inc(I);
    vLiterals[1].lBody:=FastCopy(Format,1,I-1);
   end;

   PosDecSepInFormat:=PosCh('.',Format);
   NeedDecimalCount:=0;
   CanHaveDecimalCount:=L-PosDecSepInFormat;
   for i:=L downto PosDecSepInFormat do
   begin
    if (NeedDecimalCount=0) and(Format[i]='0') then
    begin
      NeedDecimalCount:=i-PosDecSepInFormat;
    end
    else
    if NeedDecimalCount<>0 then
     if not (Format[i] in cFormatChars) then
      Dec(NeedDecimalCount);
   end;

   i:= PosDecSepInFormat-1;
   if (i>1)and not (Format[i] in cFormatChars) then
   begin
     SetLength(vLiterals,3);
     vLiterals[2].lPosType:=pBeforeDecimalSep;
     while (i>1)and not (Format[i] in cFormatChars) do
      Dec(i);
     if i>1 then
      vLiterals[2].lBody:=FastCopy(Format,i+1,PosDecSepInFormat-i-1)
     else
      vLiterals[2].lBody:=''
   end;

   i:= PosDecSepInFormat+1;
   if (i<L)and not (Format[i] in cFormatChars) then
   begin
     SetLength(vLiterals,4);
     vLiterals[3].lPosType:=pAfterDecimalSep;
     while (i<L)and not (Format[i] in cFormatChars) do
      Inc(i);
     if i<L then