hbutils.pas

Midas.dll全部源码

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff HyperBase                  }
{                                                       }
{         Utility classes and routines                  }
{                                                       }
{         Copyright (c) 1997,99 Vladimir Gaitanoff      }
{                                                       }
{*******************************************************}

{$I HB.INC}
{$D-,L-}

unit hbUtils;

interface
uses Windows, ActiveX, BDE, SysUtils, Classes, hbIntf, hbTypes,Variants;

function DefaultIndex(szName: PChar): Boolean;

procedure CreateDataPacket(const Buff; Count: Integer; var SA: PSafeArray);

procedure DataPacketToStream(SA: PSafeArray; Stream: TStream);

procedure FreeAttrInfo(var AttrInfo: TAttrInfo);

procedure FreeAttrInfos(var AttrInfos: TAttrInfos);

procedure SetAttrInfo(var AttrInfo: TAttrInfo;
  iFldNo: DWord; AAttr: PChar; AAttrType, ALen: DWord; AValue: Pointer);

procedure DeleteAttrInfo(var AttrInfos: TAttrInfos; Index: Integer);

procedure RemoveAttrInfo(var AttrInfos: TAttrInfos; iFldNo: DWord; AAttr: PChar);

procedure AddAttrInfo(var AttrInfos: TAttrInfos;
  iFldNo: DWord; AAttr: PChar; AAttrType, ALen: DWord; AValue: Pointer);

function FindOptAttribute(const AttrInfos: TAttrInfos; iFldNo: DWord; pszAttr: PChar): Integer;

function GetOptAttribute(const AttrInfos: TAttrInfos; iNo, iFldNo: DWord; var ppName: Pointer;
  var piType, piLen: DWord; var ppValue: Pointer): DBIResult;

function AttrToVariant(ParamType, ParamLen: DWord; Value: Pointer): OleVariant;

function GetVariantAttribute(const AttrInfos: TAttrInfos; const ParamName: string; FieldNo: Integer; Required: Boolean = False): OleVariant;

procedure AddOptAttribute(var AttrInfos: TAttrInfos; iFldNo: DWord; pszAttr: PChar; iType,
  iLen: DWord; pValue: Pointer; CheckDuplicates: Boolean = False);

procedure AddVariantAttribute(var AttrInfos: TAttrInfos; iFieldNo: DWord; const ParamName: string;
  const Value: OleVariant; IncludeInDelta: Boolean; CheckDuplicates: Boolean = False);

procedure FreeFieldInfos(var Infos: TFldInfos);

procedure FreeFieldDatas(var FldDatas: TFldDatas);

procedure AddFldInfo(var AFldInfos: TFldInfos; const AFldDes: TDSDataPacketFldDesc);

function GetFieldSubType(FieldType: Integer; const SubType: string): Integer;
procedure FldDescToPacketDS(const Fld: DSFLDDesc; iFieldNo: DWord; var FldDesc: TDSDataPacketFldDesc; var AttrInfos: TAttrInfos);
procedure PacketDSToFldDesc(const FldDesc: TDSDataPacketFldDesc; iFieldNo: DWord; const AttrInfos: TAttrInfos; var Fld: DSFLDDesc);
procedure WriteAttributes(const Writer: IDSWriter; const AttrInfos: TAttrInfos; FieldNo: DWord);

procedure InitLinkField(var FldDesc: DSFLDDesc);
procedure AddFieldDesc(var FieldDescs: DSFLDDescList; const FldDesc: DSFLDDesc);


function GetRecordAttr(pRecBuf: PChar): DSAttr;
procedure SetRecordAttr(pRecBuf: PChar; Attr: DSAttr);
function GetRecordRecNo(pRecBuf: PChar): Integer;
procedure SetRecordRecNo(pRecBuf: PChar; RecNo: Integer);

procedure CopyBlob(Source, Dest: PBlobData);
procedure CopyField(const SourceField, DestField: DSFLDDesc; pSourceRec, pDestRec: PChar);

function IsKeyField(const IndexDS: DSIDXDesc; iFieldNo: Integer): Boolean;

function PacketFieldType(iFieldType: DWord): DWord;

function ComputeInfoCount(const FldInfos: TFldInfos; Root: Integer): Integer;

procedure ResetElemCounters(var FldInfos: TFldInfos);

function GetValuePtr(const Value: Variant; iFldType: Integer): Pointer;

function AttrComp(Str1, Str2: PChar): Integer;

implementation
uses ComObj, vg3SysUtils, hbErrors;

{ Indexes }

function DefaultIndex(szName: PChar): Boolean;
begin
  Result := (StrIComp(szName, szDEFAULT_ORDER) = 0) or
     (StrIComp(szName, szCHANGEINDEX) = 0);
end;

{ Data packets }

procedure CreateDataPacket(const Buff; Count: Integer; var SA: PSafeArray);
var
  Data: Pointer;
  VarBounds: array[0..0] of TVarArrayBound;
begin
  with VarBounds[0] do
  begin
    LowBound := 0;
    ElementCount := Count;
  end;
  SA := SafeArrayCreate(varByte, 1, VarBounds);
  try
    OleCheck(SafeArrayAccessData(SA, Data));
    try
      Move(Buff, Data^, Count);
    finally
      SafeArrayUnaccessData(SA);
    end;
  except
    SafeArrayDestroy(SA);
    raise;
  end;
end;

procedure DataPacketToStream(SA: PSafeArray; Stream: TStream);
var
  Data: Pointer;
begin
  OleCheck(SafeArrayAccessData(SA, Data));
  try
    Stream.Size := DataPacketSize(SA);
    Stream.Position := 0;
    Stream.WriteBuffer(Data^, Stream.Size);
  finally
    SafeArrayUnaccessData(SA)
  end;
end;

{ Optional attributes }

procedure SetAttrInfo(var AttrInfo: TAttrInfo;
  iFldNo: DWord; AAttr: PChar; AAttrType, ALen: DWord; AValue: Pointer);
begin
  with AttrInfo do
  begin
    iFieldNo := iFldNo;
    Attr := StrNew(AAttr);
    AttrType := AAttrType;
    Len := ALen;
    Value := nil;
    ReallocMem(Value, Len);
    Move(AValue^, Value^, Len);
  end;
end;

procedure DeleteAttrInfo(var AttrInfos: TAttrInfos; Index: Integer);
begin
  FreeAttrInfo(AttrInfos[Index]);
  Move(AttrInfos[Index + 1], AttrInfos[Index], (High(AttrInfos) - Index) * SizeOf(TAttrInfo));
  SetLength(AttrInfos, Length(AttrInfos) - 1);
end;

procedure RemoveAttrInfo(var AttrInfos: TAttrInfos; iFldNo: DWord; AAttr: PChar);
var
  I: Integer;
begin
  I := FindOptAttribute(AttrInfos, iFldNo, AAttr);
  if I >= 0 then DeleteAttrInfo(AttrInfos, I);
end;

procedure AddAttrInfo(var AttrInfos: TAttrInfos;
  iFldNo: DWord; AAttr: PChar; AAttrType, ALen: DWord; AValue: Pointer);
begin
  SetLength(AttrInfos, Length(AttrInfos) + 1);
  SetAttrInfo(AttrInfos[High(AttrInfos)], iFldNo, AAttr, AAttrType, ALen, AValue);
end;

procedure AddVariantAttribute(var AttrInfos: TAttrInfos; iFieldNo: DWord; const ParamName: string;
  const Value: OleVariant; IncludeInDelta: Boolean; CheckDuplicates: Boolean = False);
var
  ParamType, ParamLen, ElemSize, ElemCount: Integer;
  P: Pointer;
  Buffer: array[0..8191] of Char;
begin
  if ((VarType(Value) and varTypeMask) in [varSmallInt, varInteger, varSingle,
      varDouble, varCurrency, varDate, varOleStr, varBoolean, varByte]) then
  begin
    ParamType := ParamTypeMap[VarType(Value) and varTypeMask];
    ParamLen := ParamTypeSize[VarType(Value) and varTypeMask];
    if ParamType = dsfldZSTRING then
    begin
      ParamType := (dsfldZSTRING shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Word);
      ParamLen := Length(Value) + 1;
      PWord(@Buffer)^ := ParamLen;
      Inc(ParamLen, SizeOf(Word));
      StrPCopy(@Buffer[SizeOf(Word)], Value);
    end else
    if VarIsArray(Value) then
    begin
      if ParamLen = 0 then
        HBError(DBIERR_INVALIDOPTPARAM);
      ElemCount := VarArrayHighBound(Value, 1) + 1;
      ElemSize := ParamLen;
      ParamType := (dsfldUINT shl dsSizeBitsLen) or dsArrayFldType or ElemSize;
      PInteger(@Buffer)^ := ElemCount;
      ParamLen := ElemCount * ElemSize;
      P := VarArrayLock(Value);
      try
        Move(P^, Buffer[SizeOf(Integer)], ParamLen);
        Inc(ParamLen, SizeOf(Integer));
      finally
        VarArrayUnlock(Value);
      end;
    end else
    begin
      if (VarType(Value) and varByRef) = varByRef then
        P := TVarData(Value).VPointer else
        P := @TVarData(Value).VPointer;
      Move(P^, PByte(@Buffer)^, ParamLen);
      ParamType := ParamType shl dsSizeBitsLen or ParamLen;
    end;
    if IncludeInDelta then
      ParamType := ParamType or Integer(dsIncInDelta);

    AddOptAttribute(AttrInfos, iFieldNo, PChar(ParamName), ParamType, ParamLen, PByte(@Buffer), CheckDuplicates);
  end else
    HBError(DBIERR_INVALIDOPTPARAM);
end;

function AttrToVariant(ParamType, ParamLen: DWord; Value: Pointer): OleVariant;
var
  P: Pointer;
  S: string;
  Tmp: Variant;
  ElemType, ElemCount: DWord;
begin
  if ParamType and dsArrayFldType <> 0 then
  begin
    ElemType := varUnknown;
    case ParamType and dsSizeBitsMask of
      1: ElemType := varByte;
      2: ElemType := varSmallInt;
      4: ElemType := varInteger;
      8: ElemType := varDouble;
    else
      HBError(DBIERR_NOTSUPPORTED);
    end;
    ElemCount := PInteger(Value)^;
    Tmp := VarArrayCreate([0, ElemCount - 1], ElemType);
    P := VarArrayLock(Tmp);
    try
      Move(PChar(Value)[SizeOf(Integer)], P^, ElemCount * (ParamType and dsSizeBitsMask));
    finally
      VarArrayUnlock(Tmp);
    end;
    Result := Tmp;
    Exit;
  end;

  case (ParamType and dsTypeBitsMask) shr dsSizeBitsLen of
    dsfldINT,
    dsfldUINT:
    begin
      case ParamLen of
        1: Result := Byte(Value^);
        2: Result := SmallInt(Value^);
        4: Result := Integer(Value^);
      end;
    end;
    dsfldBOOL: Result := WordBool(Value^);
    dsfldFLOATIEEE: Result := Double(Value^);
    dsfldBCD: Result := Currency(Value^);
    dsfldDATE: Result := TDateTimeRec(Value^).Date - DateDelta;
    dsfldTIME: Result := TDateTimeRec(Value^).Time / MSecsPerDay;
    dsfldTIMESTAMP: Result := (TDateTimeRec(Value^).DateTime / MSecsPerDay) - DateDelta;
    dsfldZSTRING:
    begin
      SetString(S, PChar(Value) + SizeOf(Word), ParamLen - SizeOf(Word) - 1);
      Result := S;
    end;
    dsfldBYTES:
    begin
      Tmp := VarArrayCreate([0, ParamLen], varByte);
      P := VarArrayLock(Tmp);
      try
        Move(Value^, P^, ParamLen);
      finally
        VarArrayUnlock(Tmp);
      end;
      Result := Tmp;
    end;
  else
    VarClear(Result);
  end;
end;

function GetVariantAttribute(const AttrInfos: TAttrInfos; const ParamName: string; FieldNo: Integer; Required: Boolean = False): OleVariant;
var
  ParamType, ParamLen: DWord;
  Name: PChar;
  Value: Pointer;
begin
  VarClear(Result);
  Name := PChar(ParamName);
  if GetOptAttribute(AttrInfos, 0, FieldNo, Pointer(Name), ParamType,
    ParamLen, Value) <> 0 then Exit;
  Result := AttrToVariant(ParamType, ParamLen, Value);
  if Required and VarIsEmpty(Result) then
    HBError(DBIERR_REQOPTPARAM);
end;

procedure FreeAttrInfo(var AttrInfo: TAttrInfo);
begin
  with AttrInfo do
  begin
    StrDispose(Attr);
    FreeMem(Value);
  end;
end;

procedure FreeAttrInfos(var AttrInfos: TAttrInfos);
var
  I: Integer;
begin
  for I := 0 to High(AttrInfos) do
    FreeAttrInfo(AttrInfos[I]);
  AttrInfos := nil;
end;

function FindOptAttribute(const AttrInfos: TAttrInfos; iFldNo: DWord; pszAttr: PChar): Integer;
begin
  for Result := 0 to High(AttrInfos) do
    with AttrInfos[Result] do
      if (iFieldNo = iFldNo) and (StrComp(pszAttr, Attr) = 0) then Exit;

 Result := -1;
end;

function GetOptAttribute(const AttrInfos: TAttrInfos; iNo, iFldNo: DWord; var ppName: Pointer;
  var piType, piLen: DWord; var ppValue: Pointer): DBIResult;
var
  I: Integer;
begin
  if iNo > 0 then
    I := iNo - 1 else
    I := FindOptAttribute(AttrInfos, iFldNo, ppName);

  if (I >= 0) and (I <= High(AttrInfos))then
  with AttrInfos[I] do
  begin
    ppName := Attr;
    piType := AttrType;
    piLen := Len;
    ppValue := Value;
    Result := DBIERR_NONE;
  end else
    Result := DBIERR_INVALIDOPTPARAM;
end;

procedure AddOptAttribute(var AttrInfos: TAttrInfos; iFldNo: DWord; pszAttr: PChar; iType,
  iLen: DWord; pValue: Pointer; CheckDuplicates: Boolean = False);
var
  I: Integer;
begin
  if CheckDuplicates then
    I := FindOptAttribute(AttrInfos, iFldNo, pszAttr) else
    I := -1;
  if I < 0 then
    AddAttrInfo(AttrInfos, iFldNo, pszAttr, iType, iLen, pValue) else
    SetAttrInfo(AttrInfos[I], iFldNo, pszAttr, iType, iLen, pValue);
end;

{ Field descriptions }

procedure FreeFieldDatas(var FldDatas: TFldDatas);
begin
  FldDatas := nil;
end;

procedure FreeFieldInfos(var Infos: TFldInfos);
var
  I: Integer;
begin
  for I := 0 to High(Infos) do
    FreeFieldDatas(Infos[I].FldDatas);
end;

procedure AddFldInfo(var AFldInfos: TFldInfos; const AFldDes: TDSDataPacketFldDesc);
var
  H: Integer;
  FldInfo, PrevFldInfo: PFldInfo;
begin
  SetLength(AFldInfos, Length(AFldInfos) + 1);
  H := High(AFldInfos);
  FldInfo := @AFldInfos[H];
  FldInfo.FldDes := AFldDes;
  if (H > 0) then
  begin
    PrevFldInfo := @AFldInfos[H - 1];
    with PrevFldInfo.FldDes do
    begin
      FldInfo.FldArrayElem := PacketFieldType(iFieldType) = dsfldArray;
      if FldInfo.FldArrayElem then
        FldInfo.FldArrayElemCount := iFieldType and dsSizeBitsMask;
    end;
  end;
end;

procedure FldDescToPacketDS(const Fld: DSFLDDesc; iFieldNo: DWord; var FldDesc: TDSDataPacketFldDesc; var AttrInfos: TAttrInfos);
var
  FldType, Prec, Attr, Width: Integer;
  TempStr: string;
begin
  Width := 0;