stdfuncs.pas

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

{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ InterBase databases                                           }
{                                                               }
{    FIBPlus is based in part on the product                    }
{    Free IB Components, written by Gregory H. Deatz for        }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.            }
{    mailto:[e-mail]                                    }
{                                                               }
{    Copyright (c) 1998-2007 Devrace Ltd.                       }
{    Written by Serge Buzadzhy ([e-mail])               }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page: http://www.fibplus.com/                 }
{    FIBPlus support  : http://www.devrace.com/support/         }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}

(*
 * StdFuncs -
 *   A file chock full of functions that should exist in Delphi, but
 *   dont, like "Max", "GetTempFile", "Soundex", etc...
 *)
unit StdFuncs;

{$i FIBPlus.inc}

interface

uses

 Classes, SysUtils,DB,
 {$IFDEF WINDOWS}
   Windows,Messages
  {$IFDEF D6+},FMTBcd, Variants{$ELSE},ExtCtrls  {$ENDIF};
 {$ENDIF}
 {$IFDEF LINUX}
   Types,FMTBcd, Variants;
 {$ENDIF}

type
  EParserError = class(Exception);
  TCharSet = set of Char;
  TDynArray = array of variant;
  PDynArray=^TDynArray;
  
{$IFDEF WINDOWS}
 {$IFNDEF D6+}
  TFIBTimer = TTimer;
 {$ELSE}
  TFIBTimer = class(TComponent)
  private
    FInterval: Cardinal;
    FWindowHandle: HWND;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
    procedure WndProc(var Msg: TMessage);
  protected
    procedure Timer; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;
 {$ENDIF}
{$ENDIF}
{$IFDEF LINUX}
  TFIBTimer = class(TComponent)
  private
    FEnabled: Boolean;
    FInterval: Cardinal;
    FKeepAlive: Boolean;
    FOnTimer: TNotifyEvent;
    FStreamedEnabled: Boolean;
    FTr: TThread;
    procedure SetEnabled(const Value: Boolean);
    procedure SetInterval(const Value: Cardinal);
    procedure SetOnTimer(const Value: TNotifyEvent);
    procedure SetKeepAlive(const Value: Boolean);
  protected
    procedure DoOnTimer;
    procedure Loaded; override;
    procedure StopTimer;
    procedure UpdateTimer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default False;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property KeepAlive: Boolean read FKeepAlive write SetKeepAlive default False;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;


  TTimeThread = class(TThread)
  private
    FSusp: Boolean;
    FInt: Cardinal;
    FTimer: TFIBTimer;
  protected
    procedure DoSuspend;
    procedure Execute; override;
  public
    constructor Create(ATimer: TFIBTimer);
    destructor Destroy; override;
    procedure Stop;
    property Interval: Cardinal read FInt;
  end;
{$ENDIF}



function ConvertFromBase(sNum: String; iBase: Integer; cDigits: String): Integer;
function ConvertToBase(iNum, iBase: Integer; cDigits: String): String;




function Max(n1, n2: Integer): Integer;
function MaxD(n1, n2: Double): Double;
function Min(n1, n2: Integer): Integer;{$IFDEF D9+} inline;{$ENDIF}
function MinD(n1, n2: Double): Double;
function Signum(Arg:Integer) :Integer; {$IFDEF D9+} inline;{$ENDIF}

function RandomString(iLength: Integer): String;
//function RandomInteger(iLow, iHigh: Integer): Integer;
function Soundex(st: String): String;
function StripString(const st: String; const CharsToStrip: String): String;
function ClosestWeekday(const d: TDateTime): TDateTime;
function Year(d: TDateTime): Integer;
function Month(d: TDateTime): Integer;
function DayOfYear(d: TDateTime): Integer;
function DayOfMonth(d: TDateTime): Integer;

procedure WeekOfYear(d: TDateTime; var Year, Week: Integer);
function  Degree10(Degree:integer):Extended;{$IFDEF D9+} inline;{$ENDIF}
function  ExtPrecision(Value:Extended) :integer;{$IFDEF D9+} inline;{$ENDIF}
function  RoundExtend(Value: Extended;Decimals:integer): Extended;

// Comp type stuff


function  CompWithScaleToStr(Value: Int64;Scale:integer;DSep:Char): string; overload;


//end Comp type stuff

function  Int64ToBCD(Value: Int64;Scale:integer; var BCD: TBcd ): Boolean; {$IFDEF D9+} inline;{$ENDIF}
function  ExtendedToBCD(const Value:Extended;NeedScale:integer):TBCD;

function  BCDToExtended(BCD: TBcd; var Value: Extended): Boolean;
function  BCDToCompWithScale(BCD: TBcd; var Value: Int64;var Scale:byte): Boolean;
{$IFNDEF D6+}
function  BCDToStr(BCD: TBcd): String;
{$ENDIF}
function  BCDToSQLStr(BCD: TBcd): String;
function  CompareBCD(const BCD1,BCD2: TBcd): integer;{$IFDEF D9+} inline;{$ENDIF}
{$IFDEF D6+}
function  fFormatBcd(const Format: string; Bcd: TBcd): string;
function  FormatNumericString(const Format,Source: string; OneSectionFormat:boolean=False ): string;
{$ENDIF}




function  TimeStamp(const aDate,aTime:integer):TTimeStamp;
function  CmpFullName(cmp:TComponent):string;
function  CmpInLoadedState(Cmp:TComponent):boolean;  {$IFDEF D9+} inline;{$ENDIF}
procedure FullClearStrings(aStrings:TStrings);

function HookTimeStampToMSecs(const TimeStamp:TTimeStamp): Int64;
function HookTimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;
function IBStrToTime(const Str:string):TDateTime;

function IntDateToDateTime(aDate:integer):TDateTime;
//DB rtns


function FieldOldValAsString(Field:TField;SQLFormat:boolean):string;

function BCDFieldAsSQLString(Field:TField;OldVal:boolean):variant;
function BCDFieldAsString(Field:TField;OldVal:boolean):variant;
function GetBCDFieldData(Field:TField;OldVal:boolean; var BCD:TBcd):boolean;

function GetBit(InByte:Byte; Index:byte):Boolean;{$IFDEF D9+} inline;{$ENDIF}
function SetBit(InByte:Byte; Index:byte; value :Boolean):Byte;

function HexStr2Int(const S: String): Integer;
function HexStr2IntStr(const S: String): string;

{$IFNDEF D6+}
type
  PBoolean      = ^Boolean;
function CreateGUID(out Guid: TGUID): HResult;
//function IsEqualGUID(const guid1, guid2: TGUID): Boolean;  stdcall;  {$EXTERNALSYM IsEqualGUID}


function DirectoryExists(const Name: string): Boolean;
function ForceDirectories(Dir: string): Boolean;

{$ENDIF}
procedure InitFPU;


procedure StreamToVariant(Stream:TMemoryStream; var Value : Variant);
procedure StreamToVariantArray(Stream:TMemoryStream; var Value : Variant);
function  VariantToStream(Value : Variant;Stream:TStream): integer; {Length of Blob}

function  StringIsDateTimeDefValue(const s:string):boolean; {$IFDEF D9+} inline;{$ENDIF}

{$IFNDEF D6+}
// Cut from system.pas Delphi 6
 function Utf8Encode(const WS: WideString): String;
 function Utf8Decode(const S: String): WideString;
{$ENDIF}

{$IFDEF WINDOWS}
function ConvertFromCodePage( const Source : string; FromCodePage:LongWord) : WideString;
function ConvertToCodePage(const Source : WideString; ToCodePage : LongWord) : string;
{$ENDIF}
var
  TempPath: PChar;
  TempPathLength: Integer;

const
    E10:array [-18..18] of Double =
     ( 1E-18,1E-17, 1E-16, 1E-15, 1E-14, 1E-13, 1E-12, 1E-11,
       1E-10, 1E-9, 1E-8, 1E-7, 1E-6, 1E-5, 1E-4, 1E-3,1E-2, 1E-1,
       1,
       1E1, 1E2, 1E3, 1E4, 1E5, 1E6, 1E7, 1E8,1E9, 1E10,
       1E11, 1E12, 1E13, 1E14, 1E15, 1E16, 1E17, 1E18
      );


    IE10:array [0..18] of int64 =
     (
       1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000,1000000000,
       10000000000,100000000000,1000000000000,10000000000000,100000000000000,
       1000000000000000,10000000000000000,100000000000000000,1000000000000000000
      );
      
const
   AppPathTemplate='{APP_PATH}';


implementation

uses FIBConsts,StrUtil;


{$IFDEF WINDOWS}

function ConvertToCodePage(const Source : WideString;
                           ToCodePage : LongWord) : string;
var
      L :integer;
begin
   L := Length(Source);
   SetLength(Result,L);
   if
    WideCharToMultiByte(ToCodePage, 0,  PWideChar(Source), L, PChar(Result), L, nil, nil)=0
   then
    Result:=Source
end;

function ConvertFromCodePage(const Source : string; FromCodePage:LongWord) : WideString;
var
      L :integer;
begin
  L := Length(Source);
  SetLength(Result,L);
  if
   MultiByteToWideChar(FromCodePage, 0,  PChar(Source), L, PWideChar(Result), L)=0
  then
    Result :=Source
end;
{$ENDIF}


{$IFNDEF D6+}
// Cut from system.pas Delphi 6
function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
var
  i, count: Cardinal;
  c: Cardinal;
begin
  Result := 0;
  if Source = nil then Exit;
  count := 0;
  i := 0;
  if Dest <> nil then
  begin
    while (i < SourceChars) and (count < MaxDestBytes) do
    begin
      c := Cardinal(Source[i]);
      Inc(i);
      if c <= $7F then
      begin
        Dest[count] := Char(c);
        Inc(count);
      end
      else if c > $7FF then
      begin
        if count + 3 > MaxDestBytes then
          break;
        Dest[count] := Char($E0 or (c shr 12));
        Dest[count+1] := Char($80 or ((c shr 6) and $3F));
        Dest[count+2] := Char($80 or (c and $3F));
        Inc(count,3);
      end
      else //  $7F < Source[i] <= $7FF
      begin
        if count + 2 > MaxDestBytes then
          break;
        Dest[count] := Char($C0 or (c shr 6));
        Dest[count+1] := Char($80 or (c and $3F));
        Inc(count,2);
      end;
    end;
    if count >= MaxDestBytes then count := MaxDestBytes-1;
    Dest[count] := #0;
  end
  else
  begin
    while i < SourceChars do
    begin
      c := Integer(Source[i]);
      Inc(i);
      if c > $7F then
      begin
        if c > $7FF then
          Inc(count);
        Inc(count);
      end;
      Inc(count);
    end;
  end;
  Result := count+1;  // convert zero based index to byte count
end;

function Utf8Encode(const WS: WideString): String;
var
  L: Integer;
  Temp: String;
begin
  Result := '';
  if WS = '' then Exit;
  SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator

  L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp := '';
  Result := Temp;
end;

function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal;
var
  i, count: Cardinal;
  c: Byte;
  wc: Cardinal;
begin
  if Source = nil then
  begin
    Result := 0;
    Exit;
  end;
  Result := Cardinal(-1);
  count := 0;
  i := 0;
  if Dest <> nil then
  begin
    while (i < SourceBytes) and (count < MaxDestChars) do
    begin
      wc := Cardinal(Source[i]);
      Inc(i);
      if (wc and $80) <> 0 then
      begin
        wc := wc and $3F;
        if i > SourceBytes then Exit;           // incomplete multibyte char
        if (wc and $20) <> 0 then
        begin
          c := Byte(Source[i]);
          Inc(i);
          if (c and $C0) <> $80 then  Exit;     // malformed trail byte or out of range char
          if i > SourceBytes then Exit;         // incomplete multibyte char
          wc := (wc shl 6) or (c and $3F);
        end;
        c := Byte(Source[i]);
        Inc(i);
        if (c and $C0) <> $80 then Exit;       // malformed trail byte

        Dest[count] := WideChar((wc shl 6) or (c and $3F));
      end
      else
        Dest[count] := WideChar(wc);
      Inc(count);
    end;
	if count >= MaxDestChars then count := MaxDestChars-1;
	Dest[count] := #0;
  end
  else
  begin
	while (i <= SourceBytes) do
	begin
	  c := Byte(Source[i]);
	  Inc(i);
	  if (c and $80) <> 0 then
	  begin
		if (c and $F0) = $F0 then Exit;  // too many bytes for UCS2
		if (c and $40) = 0 then Exit;    // malformed lead byte
		if i > SourceBytes then Exit;         // incomplete multibyte char

		if (Byte(Source[i]) and $C0) <> $80 then Exit;  // malformed trail byte
		Inc(i);
		if i > SourceBytes then Exit;         // incomplete multibyte char
		if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte
		Inc(i);
	  end;
	  Inc(count);
	end;
  end;
  Result := count+1;
end;

function Utf8Decode(const S: String): WideString;
var
  L: Integer;
  Temp: WideString;
begin
  Result := '';
  if S = '' then Exit;
  SetLength(Temp, Length(S));

  L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp := '';
  Result := Temp;
end;

{$ENDIF}

{$IFDEF LINUX}
{SVD TTimeThread }

constructor TTimeThread.Create(ATimer: TFIBTimer);
begin
  inherited Create(True);

  FreeOnTerminate := True;
  FInt := ATimer.FInterval;
  FTimer := ATimer;
  Priority := 0;
  Resume;
end;

destructor TTimeThread.Destroy;
begin
  Stop;
  inherited Destroy;
end;

procedure TTimeThread.DoSuspend;
begin
  FSusp := True;
  Suspend;
end;

procedure TTimeThread.Execute;
var
  TickCount: Comp;
  function GetTickCount: Comp;
  begin
     Result := TimeStampToMSecs(DateTimeToTimeStamp(Now));
  end;
begin

  while not Terminated do
  begin
    FSusp := False;

    TickCount := GetTickCount;

    while (not Terminated)and(GetTickCount - FInt  < TickCount) do
      Sleep(1);

    if not Terminated then
      Synchronize(FTimer.DoOnTimer);
  end;
end;

procedure TTimeThread.Stop;
begin
  Terminate;
  if Suspended then
    Resume;
  Sleep(0);
end;

constructor TFIBTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FInterval := 1000;
end;

destructor TFIBTimer.Destroy;
begin
  StopTimer;
  inherited Destroy;
end;

procedure TFIBTimer.DoOnTimer;
begin
  if csDestroying in ComponentState then
    Exit;

  try
    if Assigned(FOnTimer) then
      FOnTimer(Self);
  except
    raise Exception.Create('DoOnTimer');
  end;
end;

procedure TFIBTimer.Loaded;
begin
  inherited Loaded;
  SetEnabled(FStreamedEnabled);
end;

procedure TFIBTimer.SetEnabled(const Value: Boolean);
begin
  if csLoading in ComponentState then
    FStreamedEnabled := Value
  else
  if FEnabled <> Value then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TFIBTimer.SetInterval(const Value: Cardinal);
begin
  if FInterval <> Value then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TFIBTimer.SetKeepAlive(const Value: Boolean);
begin
  if FKeepAlive <> Value then
  begin
    StopTimer;
    FKeepAlive := Value;
    UpdateTimer;
  end;
end;

procedure TFIBTimer.SetOnTimer(const Value: TNotifyEvent);
begin
  if @FOnTimer <> @Value then
  begin
    FOnTimer := Value;
    UpdateTimer;
  end;
end;

procedure TFIBTimer.StopTimer;
begin
  if FTr is TTimeThread then
    TTimeThread(FTr).Stop;
  FTr := nil;
end;

procedure TFIBTimer.UpdateTimer;
var
  DoEnable: Boolean;
begin
  if ComponentState * [csDesigning, csLoading] <> [] then
    Exit;

  DoEnable := FEnabled and Assigned(FOnTimer) and (FInterval > 0);

  if not KeepAlive then
    StopTimer;

  if DoEnable then
  begin
    if FTr is TTimeThread then
      TTimeThread(FTr).FInt := FInterval
    else
      FTr := TTimeThread.Create(Self);

    if FTr.Suspended then
      FTr.Resume;
  end
  else
  if FTr is TTimeThread then