stdfuncs.pas

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

      vLiterals[3].lBody:=FastCopy(Format,PosDecSepInFormat+1,i-PosDecSepInFormat-1)
     else
      vLiterals[3].lBody:=''
   end;

   PosDecSepInString:=PosCh(DecimalSeparator,Result);
   if (PosDecSepInString=0) and (NeedDecimalCount>0) then
   begin
    Result:=Result+DecimalSeparator;
    PosDecSepInString:=Length(Result)
   end;
   if (PosDecSepInString>0) then
   begin
     if Length(Result)-PosDecSepInString<NeedDecimalCount then
     begin
        if NeedDecimalCount>0 then
         Result:=
          Result+FastCopy(ZeroStr,1,NeedDecimalCount-(Length(Result)-PosDecSepInString))
     end
     else
     if Length(Result)-PosDecSepInString>CanHaveDecimalCount then
     begin
      Result:=RoundAt(Result,CanHaveDecimalCount)
     end;
   end;
   //
   if Length(vLiterals)>3 then
   begin
      Result:= FastCopy(Result,1,PosDecSepInString)+vLiterals[3].lBody+
        FastCopy(Result,PosDecSepInString+1,MaxInt)
      ;
   end;

   if Length(vLiterals)>2 then
   begin
     if PosDecSepInString>0 then
      Result:= FastCopy(Result,1,PosDecSepInString-1)+vLiterals[2].lBody+
        FastCopy(Result,PosDecSepInString,MaxInt)
     else
      Result:= Result+vLiterals[2].lBody;
   end;

   if PosCh(',',Format)>0 then
   begin
    L:=1;
    i:=PosDecSepInString-1;
    while i>1 do
    begin
      if L=3 then
      begin
        if (i<>2) or not (Result[1] in ['+','-']) then
        Result:=FastCopy(Result,1,i-1)+ThousandSeparator+FastCopy(Result,i,MaxInt);
        L:=0
      end
      else
      begin
       Dec(i);
       Inc(L)
      end;
    end;
   end;
   if Length(vLiterals)>1 then
    PosDecSepInFormat:=PosDecSepInFormat-Length(vLiterals[1].lBody);
   if (PosDecSepInFormat=1) then
   begin
     if (PosDecSepInString=2)  and (Result[1]='0')   then
       Delete(Result,1,1)
     else
     if (PosDecSepInString=3) and (Result[1]='-') and (Result[2]='0')   then
       Delete(Result,2,1);
   end;

   if Result[Length(Result)]=DecimalSeparator then
    SetLength(Result,Length(Result)-1);
   if OneSectionFormat and (Result[1]='-') then
     Delete(Result,1,1);
   if Length(vLiterals)>0 then
   begin
    Result:= Result+vLiterals[0].lBody;
    if Length(vLiterals)>1 then
    begin
      Result:= vLiterals[1].lBody+Result;
    end;
   end;
 end;
end;
{$WARNINGS ON}
function  fFormatBcd(const Format: string; Bcd: TBcd): string;
begin
 Result:=FormatNumericString(Format,BCDToStr(Bcd));
end;
{$ENDIF}

function  BCDToExtended(BCD: TBcd; var Value: Extended): Boolean;
var c:Int64;
    Scale:byte;
begin
 Result:= BCDToCompWithScale(BCD,c,Scale);
 if Result then
  Value :=C*E10[-Scale]
end;

function  CompareBCD(const BCD1,BCD2: TBcd): integer;
var e1,e2:extended;
begin
 BCDToExtended(Bcd1,e1);
 BCDToExtended(Bcd2,e2);
 if e1=e2 then
  Result:=0
 else
 if e1<e2 then
  Result:=-1
 else
  Result:=1
end;






function  CompWithScaleToStr(Value: Int64;Scale:integer;DSep:Char): string;
var i,j:integer;
    IntStr,DecStr:string;
    sign:string[1];
begin
 if Value=0 then
 begin
  Result:='0';
  Exit;
 end;
 Result:= IntToStr(Value);
 if Scale>0 then
 begin
   if Result[1]='-' then
   begin
    sign:='-';
    Delete(Result,1,1);
   end
   else
    sign:='';
  j:=Length(Result)-Scale ;
  if j>0 then
  begin
    IntStr:=sign+ FastCopy(Result,1,j);
    DecStr:=FastCopy(Result,j+1,Length(Result));
  end
  else
  begin
   IntStr:=sign+'0';
   DecStr:=MakeStr('0',-j)+Result;
  end;
  Result:= IntStr+DSep+DecStr;
  i:=Length(Result);
  while Result[i] = '0' do
  begin
    Dec(i);
    if Result[i]=DSep then
    begin
     Dec(i);Break;
    end;
  end;
   Delete(Result,i+1,Length(Result));
 end;
end;

{$IFNDEF D6+}
function  BCDToStr(BCD: TBcd): String;

var  c:Int64;
     Scale:byte;
begin
 if BCDToCompWithScale(BCD,c,Scale) then
  Result:=CompWithScaleToStr(c,Scale,DecimalSeparator)
 else
  Result:=''
end;
{$ENDIF}


//
function ConvertFromBase(sNum: String; iBase: Integer; cDigits: String): Integer;
var
  i: Integer;

  function GetValue(c: Char): Integer;
  var
    i: Integer;
  begin
    result := 0;
    for i := 1 to Length(cDigits) do
      if (cDigits[i] = c) then
      begin
        result := i - 1;
        exit;
      end;
  end;

begin
  result := 0;
  for i := 1 to Length(sNum) do
    result := (result * iBase) + GetValue(sNum[i]);
end;

function ConvertToBase(iNum, iBase: Integer; cDigits: String): String;
var
  i, r: Integer;
  s: String;
const
  iLength = 16;
begin
  result := '';
  SetString(s, nil, iLength);
  i := 0;
  repeat
    r := iNum mod iBase;
    Inc(i);
    if (i > iLength) then
      SetString(s, PChar(s), Length(s) + iLength);
    s[i] := cDigits[r + 1];
    iNum := iNum div iBase;
  until iNum = 0;
  SetString(result, nil, i);
  for r := 1 to i do
    result[r] := s[i - r + 1];
end;



function Max(n1, n2: Integer): Integer;
begin
  if (n1 > n2) then
    result := n1
  else
    result := n2;
end;

function MaxD(n1, n2: Double): Double;
begin
  if (n1 > n2) then
    result := n1
  else
    result := n2;
end;

function Min(n1, n2: Integer): Integer;
begin
  if (n1 < n2) then
    result := n1
  else
    result := n2;
end;

function Signum(Arg:Integer) :integer;
begin
 if Arg>0 then Result:=1 else
  if Arg<0 then Result:=-1  else  Result:=0;
end;

function MinD(n1, n2: Double): Double;
begin
  if (n1 < n2) then
    result := n1
  else
    result := n2;
end;

function RandomInteger(iLow, iHigh: Integer): Integer;
begin
  result := Trunc(Random(iHigh - iLow)) + iLow;
end;

function RandomString(iLength: Integer): String;
begin
  result := '';
  while Length(result) < iLength do
    result := result + IntToStr(RandomInteger(0, High(Integer)));
  if Length(Result) > iLength then
    Result := FastCopy(result, 1, iLength);
end;


function Soundex(st: String): String;
var
  code: Char;
  i, j, len: Integer;
begin
  result := ' 0000';
  if (st = '') then exit;
  result[1] := UpCase(st[1]);
  j := 2;                   
  i := 2;
  len := Length(st);
  while (i <= len) and (j < 6) do
  begin
    case st[i] of
      'B', 'F', 'P', 'V', 'b', 'f', 'p', 'v' : code := '1';
      'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z',
      'c', 'g', 'j', 'k', 'q', 's', 'x', 'z' : code := '2';
      'D', 'T', 'd', 't' :                     code := '3';
      'L', 'l' :                               code := '4';
      'M', 'N', 'm', 'n' :                     code := '5';
      'R', 'r' :                               code := '6';
    else
      code := '0';
    end; {case}

    if (code <> '0') and (code <> result[j - 1]) then
    begin
      result[j] := code;
      inc(j);
    end;
    inc(i);
  end;
end;

function StripString(const st: String; const CharsToStrip: String): String;
var
  i: Integer;
begin
  result := '';
  for i := 1 to Length(st) do
  begin
    if PosCh(st[i], CharsToStrip) = 0 then
      result := result + st[i];
  end;
end;

function ClosestWeekday(const d: TDateTime): TDateTime;
begin
  if (DayOfWeek(d) = 1) then
    result := d + 1
  else
  if (DayOfWeek(d) = 7) then
    result := d + 2
  else
    result := d;
end;

function Year(d: TDateTime): Integer;
var
  y, m, day: Word;
begin
  DecodeDate(d, y, m, day);
  result := y;
end;

function Month(d: TDateTime): Integer;
var
  yr, mn, dy: Word;
begin
  DecodeDate(d, yr, mn, dy);
  result := mn;
end;

function DayOfYear(d: TDateTime): Integer;
var
  yr, mn, dy: Word;
  b: TDateTime;
begin
  DecodeDate(d, yr, mn, dy);
  b := EncodeDate(yr, 1, 1);
  result := Trunc(d - b);
end;

function DayOfMonth(d: TDateTime): Integer;
var
  yr, mn, dy: Word;
begin
  DecodeDate(d, yr, mn, dy);
  result := dy;
end;



procedure WeekOfYear(d: TDateTime; var Year, Week: Integer);
var
  yr, mn, dy: Word;
  dow_ybeg: Integer;
  ThisLeapYear, LastLeapYear: Boolean;
begin
  DecodeDate(d, yr, mn, dy);
  // When did the year begin?
  Year := yr;
  dow_ybeg := SysUtils.DayOfWeek(EncodeDate(yr, 1, 1));
  ThisLeapYear := IsLeapYear(yr);
  LastLeapYear := IsLeapYear(yr - 1);
  // Get the Sunday beginning this week.
  Week := (DayOfYear(d) - DayOfWeek(d) + 1);
  (*
   * If the Sunday beginning this week was last year, then
   *   if this year begins on a Wednesday or previous, then
   *     this is most certainly the first week of the year.
   *   if this year begins on a thursday or
   *     last year was a leap year and this year begins on a friday, then
   *     this week is 53 of last year.
   *   Otherwise this week is 52 of last year.
   *)
  if Week <= 0 then
  begin
    if (dow_ybeg <= 4) then
      Week := 1
    else
    if (dow_ybeg = 5) or (LastLeapYear and (dow_ybeg = 6)) then
    begin
      Week := 53;
      Dec(Year);
    end
    else
    begin
      Week := 52;
      Dec(Year);
    end;
  (* If the Sunday beginning this week falls in this year!!! Yeah
   *   if the year begins on a Sun, Mon, Tue or Wed then
   *     This week # is (Week + 7) div 7
   *   otherwise this week is
   *     Week div 7 + 1.
   *   if the week is > 52 then
   *     if this year began on a wed or this year is leap year and it
   *       began on a tuesday, then set the week to 53.
   *     otherwise set the week to 1 of *next* year.
   *)
  end
  else
  begin
    if (dow_ybeg <= 4) then
      Week := (Week + 6 + dow_ybeg) div 7
    else
      Week := (Week div 7) + 1;
    if Week > 52 then
    begin
      if (dow_ybeg = 4) or (ThisLeapYear and (dow_ybeg = 3)) then
        Week := 53
      else
      begin
        Week := 1;
        Inc(Year);
      end;
    end;
  end;
end;

{$IFDEF WINDOWS}
procedure InitFPU;
var
  Default8087CW: Word;
begin
  asm
    FSTCW Default8087CW
    OR Default8087CW, 0300h
    FLDCW Default8087CW
  end;
end;

{$ELSE}
procedure InitFPU;
begin

end;
{$ENDIF}
  const
    Hexez: array ['A'..'F'] of Byte = (10,11,12,13,14,15);
    HexezDecimal: array ['0'..'9'] of Byte = (0,1,2,3,4,5,6,7,8,9);

  function HexStr2Int(const S: String): Integer;
  var
    J: LongInt;
    PStart,PEnd:PChar;
  begin
    Result := 0;
    J := 1;
    PStart:=Pointer(S);
    PEnd  :=Pointer(S);
    Inc(PEnd,Length(S)-1);
    while PEnd>=PStart do
    begin
     case PEnd^ of
      '0':;
      '1': Inc(Result, J);
      '2': Inc(Result, J*2);
      '3'..'9': Inc(Result, J*HexezDecimal[PEnd^]);
      'A'..'F': Inc(Result, J*Hexez[PEnd^]);
     end;
     J:=J*16;
     Dec(PEnd)
    end;
  end;

  function HexStr2IntStr(const S: String): string;
  begin
   Result:=IntToStr(HexStr2Int(S))
  end;

var
 vBits: array[0..7]of byte =(1,2,4,8,16,32,64,128);


function GetBit(InByte:Byte; Index:byte):Boolean;
begin
 Result:= Boolean(InByte shr Index and 1)
end;

function SetBit(InByte:Byte; Index:byte; Value :Boolean):Byte;
begin
  if Value then
   Result:=InByte or vBits[Index]
  else
   Result:=InByte and not vBits[Index]
end;


{$IFDEF WINDOWS}
// Cut from ExtCtrls

{$IFDEF D6+}
constructor TFIBTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled      := True;
  FInterval     := 1000;
  FWindowHandle := AllocateHWnd(WndProc);
end;

destructor TFIBTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  DeallocateHWnd(FWindowHandle);
  inherited Destroy;
end;


procedure TFIBTimer.UpdateTimer;
begin
  KillTimer(FWindowHandle, 1);
  if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
    if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then
      raise EOutOfResources.Create(SNoTimers);
end;

procedure TFIBTimer.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

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

procedure TFIBTimer.SetOnTimer(Value: TNotifyEvent);
begin
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TFIBTimer.WndProc(var Msg: TMessage);
begin
  with Msg do
  begin
    if Msg = WM_TIMER then
      Timer
    else
     Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
  end;
end;

procedure TFIBTimer.Timer;
begin
  if Assigned(FOnTimer) then FOnTimer(Self);
end;
{$ENDIF}
{$ENDIF}

{$IFNDEF D6+}
function DirectoryExists(const Name: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Name));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

function ForceDirectories(Dir: string): Boolean;
begin
  Result := True;
  if Length(Dir) = 0 then
    raise Exception.CreateRes(Integer(@SCannotCreateDir));
  Dir := ExcludeTrailingBackslash(Dir);
  if (Length(Dir) < 3) or DirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;
{$ENDIF}

initialization
  Randomize;
end.