hbutils.pas

Midas.dll全部源码

  Attr := Fld.iFldAttr;

  FldType := PacketTypeMap[Fld.iFldType];
  case Fld.iFldType of
    fldZSTRING, fldBYTES, fldVARBYTES:
    begin
      FldType := FldType shl dsSizeBitsLen or dsVaryingFldType;
      if Fld.iUnits1 < 255 then
        FldType := FldType or SizeOf(Byte) else
        FldType := FldType or SizeOf(Word);
      Width := Fld.iUnits1;
    end;
    fldUNICODE:
    begin
      FldType := dsfldUNICODE shl dsSizeBitsLen or dsVaryingFldType;
      if Fld.iUnits1 < 255 then
        FldType := FldType or SizeOf(Byte) else
        FldType := FldType or SizeOf(Word);
      Width := Fld.iUnits1;
    end;
    fldBCD:
    begin
      Width := Fld.iUnits1;
      Prec := Width shr 1;
      Inc(Prec, Prec and 1);  { Make an even number }
      FldType := (FldType shl dsSizeBitsLen) or (Prec + 2);

      if (Fld.iUnits2 <> 0) then
        AddVariantAttribute(AttrInfos, iFieldNo, szDECIMALS, Fld.iUnits2, True, True);
    end;
    fldArray:
      FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
        dsCompArrayFldType or Fld.iUnits1;
    fldADT:
        FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
           Fld.iUnits1;
    fldREF, fldTABLE:
        FldType := (FldType shl dsSizeBitsLen) or dsPseudoFldType or
          dsEmbeddedFldType or (Fld.iUnits1 - 1) { Skip link attribute };
    fldBLOB:
      begin
        FldType := (FldType shl dsSizeBitsLen) or dsVaryingFldType or SizeOf(Integer);
        Width := Fld.iUnits1;
      end;
  else
    FldType := (FldType shl dsSizeBitsLen) or Fld.iUnits1;
  end;

  ZeroMem(@FldDesc, SizeOf(FldDesc));
  StrCopy(FldDesc.szFieldName, Fld.szName);
    FldDesc.iFieldType := FldType;
  FldDesc.iAttributes := Attr;

  if Fld.bCalculated then
    AddVariantAttribute(AttrInfos, iFieldNo, szSERVERCALC, True, True, True);

  if Width > 0 then
    AddVariantAttribute(AttrInfos, iFieldNo, szWIDTH, Width, True, True);

  case Fld.iFldSubType of
    fldstMONEY: TempStr := szstMONEY;
    fldstAUTOINC: TempStr := szstAUTOINC;
    fldstBINARY: TempStr := szstBINARY;
    fldstMEMO: TempStr := szstMEMO;
    fldstFMTMEMO: TempStr := szstFMTMEMO;
    fldstOLEOBJ: TempStr := szstOLEOBJ;
    fldstGRAPHIC: TempStr := szstGRAPHIC;
    fldstDBSOLEOBJ: TempStr := szstDBSOLEOBJ;
    fldstTYPEDBINARY: TempStr := szstTYPEDBINARY;
    fldstADTNestedTable: TempStr := szstADTNESTEDTABLE;
    fldstPASSWORD: TempStr := szstFIXEDCHAR;
    fldstFIXED: TempStr := szstFIXEDCHAR;
    fldstGUID: TempStr := szstGUID;
    fldstHMEMO: TempStr := szstHMEMO;
    fldstBFILE: TempStr := szstHBINARY;
  else
    TempStr := '';
  end;

  if TempStr <> '' then
    AddVariantAttribute(AttrInfos, iFieldNo, szSUBTYPE, TempStr, True, True);
end;

function GetFieldSubType(FieldType: Integer; const SubType: string): Integer;
begin
  Result := 0;
  case FieldType of
    fldINT32:
      begin
        if StrComp(PChar(SubType), szstAUTOINC) = 0 then
          Result := fldstAUTOINC;
      end;
    fldFLOAT:
      begin
        if StrComp(PChar(SubType), szstMONEY) = 0 then
          Result := fldstMONEY;
      end;
    fldZSTRING, fldUNICODE, fldBYTES, fldVARBYTES:
      begin
        if StrComp(PChar(SubType), szstFIXEDCHAR) = 0 then
          Result := fldstFIXED
        else if StrComp(PChar(SubType), szstGUID) = 0 then
          Result := fldstGUID;
      end;
    fldBLOB:
      begin
        if StrComp(PChar(SubType), szstBINARY) = 0 then
          Result := fldstBINARY
        else if StrComp(PChar(SubType), szstMEMO) = 0 then
          Result := fldstMEMO
        else if StrComp(PChar(SubType), szstFMTMEMO) = 0 then
          Result := fldstFMTMEMO
        else if StrComp(PChar(SubType), szstOLEOBJ) = 0 then
          Result := fldstOLEOBJ
        else if StrComp(PChar(SubType), szstGRAPHIC) = 0 then
          Result := fldstGRAPHIC
        else if StrComp(PChar(SubType), szstDBSOLEOBJ) = 0 then
          Result := fldstDBSOLEOBJ
        else if StrComp(PChar(SubType), szstTYPEDBINARY) = 0 then
          Result := fldstTYPEDBINARY
        else if StrComp(PChar(SubType), szstFIXEDCHAR) = 0 then
          Result := fldstFIXED
        else if StrComp(PChar(SubType), szstHMEMO) = 0 then
          Result := fldstHMEMO
        else if StrComp(PChar(SubType), szstHBINARY) = 0 then
          Result := fldstBFILE;
      end;
    fldADT:
      begin
        ;
      end;
    fldTABLE:
      begin
        if StrComp(PChar(SubType), szstREFNESTEDTABLE) = 0 then
          Result := fldstREFERENCE;
      end;
  end;
end;

procedure PacketDSToFldDesc(const FldDesc: TDSDataPacketFldDesc; iFieldNo: DWord; const AttrInfos: TAttrInfos; var Fld: DSFLDDesc);

  function GetWidth(iFieldNo: Integer; Required: Boolean): Integer;
  begin
    Result := GetVariantAttribute(AttrInfos, szWIDTH, iFieldNo, True);
  end;

  function SubType(FieldType: Integer): Integer;
  var
    Tmp: Variant;
  begin
    Result := 0;
    Tmp := GetVariantAttribute(AttrInfos, szSUBTYPE, iFieldNo, False);
    if VarIsEmpty(Tmp) or (Tmp = '') then Exit;
    Result := GetFieldSubType(FieldType, Tmp);
  end;

var
  Tmp: Variant;
  Len: Integer;
begin
  ZeroMem(@Fld, SizeOf(DSFLDDesc));
  StrCopy(Fld.szName, FldDesc.szFieldName);
  Fld.iFldAttr := FldDesc.iAttributes;
  Tmp := GetVariantAttribute(AttrInfos, szSERVERCALC, iFieldNo);
  if not VarIsEmpty(Tmp) then
    Fld.bCalculated := True;

  Fld.iFldType := FieldTypeMap[(FldDesc.iFieldType and dsTypeBitsMask) shr dsSizeBitsLen];
  case Fld.iFldType of
    fldUNKNOWN:
      HBError(DBIERR_NOTSUPPORTED);
    fldINT32:
      begin
        Len := (FldDesc.iFieldType and dsSizeBitsMask);
        if Len = SizeOf(SmallInt) then
          Fld.iFldType := fldINT16 else
        if Len = SizeOf(Int64) then
          Fld.iFldType := fldINT64;

        Fld.iFldSubType := SubType(Fld.iFldType);
      end;
    fldUINT32:
      begin
        Len := (FldDesc.iFieldType and dsSizeBitsMask);
        if Len = SizeOf(SmallInt) then
          Fld.iFldType := fldUINT16 else
        if Len = SizeOf(Int64) then
          Fld.iFldType := fldUINT64;

        Fld.iFldSubType := SubType(Fld.iFldType);
      end;
    fldFLOAT:
      begin
        Fld.iFldSubType := SubType(Fld.iFldType);
      end;
    fldBCD:
      begin
        Fld.iUnits1 := GetWidth(iFieldNo, True);
        Tmp := GetVariantAttribute(AttrInfos, szDECIMALS, iFieldNo, True);
        if not VarIsEmpty(Tmp) then
          Fld.iUnits2 := Tmp;
      end;
    fldZSTRING, fldUNICODE:
      begin
        Fld.iFldSubType := SubType(Fld.iFldType);
        Fld.iUnits1 := GetWidth(iFieldNo, True);
      end;
    fldBLOB:
      begin
        Fld.iFldSubType := SubType(Fld.iFldType);
        Fld.iUnits1 := GetWidth(iFieldNo, True);
      end;
    fldDATE, fldBOOL, fldTIME, fldTIMESTAMP:
      ;
    fldADT, fldARRAY:
      begin
        Fld.iUnits1 := FldDesc.iFieldType and dsSizeBitsMask;
      end;
    fldTABLE:
      begin
        Fld.iFldSubType := SubType(Fld.iFldType);
      end;
  else
    HBError(DBIERR_NIY);
  end;
end;

procedure WriteAttributes(const Writer: IDSWriter; const AttrInfos: TAttrInfos; FieldNo: DWord);
var
  I: Integer;
begin
  for I := 0 to High(AttrInfos) do
    with AttrInfos[I] do
      if iFieldNo = FieldNo then
        Check(Writer.AddAttribute(TPcktAttrArea(iFieldNo = 0), Attr, AttrType, Len, Value));
end;


procedure InitLinkField(var FldDesc: DSFLDDesc);
begin
  ZeroMem(@FldDesc, SizeOf(DSFLDDesc));
  StrCopy(FldDesc.szName, szLINK_FIELD);
  FldDesc.iFldType := fldUINT32;
  FldDesc.iFldAttr := fldAttrLINK;
end;

procedure AddFieldDesc(var FieldDescs: DSFLDDescList; const FldDesc: DSFLDDesc);
begin
  SetLength(FieldDescs, Length(FieldDescs) + 1);
  Move(FldDesc, FieldDescs[High(FieldDescs)], SizeOf(DSFLDDesc));
end;

{ Fields and records }

function GetRecordAttr(pRecBuf: PChar): DSAttr;
begin
  Result := pDSAttr(pRecBuf + RecAttrOfs)^;
end;

procedure SetRecordAttr(pRecBuf: PChar; Attr: DSAttr);
begin
  pDSAttr(pRecBuf + RecAttrOfs)^ := Attr;
end;

function GetRecordRecNo(pRecBuf: PChar): Integer;
begin
  Result := PInteger(pRecBuf + RecNoOfs)^;
end;

procedure SetRecordRecNo(pRecBuf: PChar; RecNo: Integer);
begin
  PInteger(pRecBuf + RecNoOfs)^ := RecNo;
end;

procedure CopyBlob(Source, Dest: PBlobData);
var
  P: Pointer;
begin
  if Source.IsNew then
  begin
    Move(Source^, Dest^, SizeOf(TBlobData));
    Dest.Length := 0;
    Dest.Data := nil;
  end else begin
    P := nil;
    ReallocMem(P, Source.Length and not dsDELAYEDBIT);
    try
      Move(Source.Data^, P^, Source.Length and not dsDELAYEDBIT);
      ReallocMem(Dest.Data, 0);
      Dest.Data := P;
      Dest.Length := Source.Length;
    except
      FreeMem(P);
      raise;
    end;
  end;
end;

procedure CopyField(const SourceField, DestField: DSFLDDesc; pSourceRec, pDestRec: PChar);
var
  IsBlob: Boolean;
begin
  with SourceField do
  begin
    Inc(pSourceRec, iNullOffsInRec);
    Inc(pDestRec, DestField.iNullOffsInRec);
    IsBlob := iFldType = fldBLOB;
    Move(pSourceRec^, pDestRec^, ord(not IsBlob) * iFldLen + 1);
    if IsBlob then
      CopyBlob(@(pSourceRec + 1)^, @(pDestRec + 1)^);
  end;
end;

function IsKeyField(const IndexDS: DSIDXDesc; iFieldNo: Integer): Boolean;
var
  I: Integer;
begin
  with IndexDS do
    for I := 0 to iFields - 1 do
      if iFieldNo = iKeyFields[I] then
      begin
        Result := True;
        Exit;
      end;

  Result := False;
end;

function PacketFieldType(iFieldType: DWord): DWord;
begin
  Result := (iFieldType and dsTypeBitsMask) shr dsSizeBitsLen;
end;

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

  function DoComputeInfoCount(Root: Integer): Integer;
  var
    I: Integer;
    FieldType: DWord;
  begin
    with FldInfos[Root].FldDes do
    begin
      FieldType := PacketFieldType(iFieldType);
      if FieldType = dsfldADT then
      begin
        Result := FldInfos[Root].FldDes.iFieldType and dsSizeBitsMask;
        for I := 1 to Result do
          Inc(Result, DoComputeInfoCount(Root + I));
      end else if FieldType = dsfldARRAY then
        Result := 1
      else
        Result := 0;
    end;
  end;

begin
  Result := DoComputeInfoCount(Root);
end;

procedure ResetElemCounters(var FldInfos: TFldInfos);
var
  I: Integer;
begin
  for I := 0 to High(FldInfos) do
    FldInfos[I].FldArrayElemCounter := 0;
end;

function GetValuePtr(const Value: Variant; iFldType: Integer): Pointer;
begin
  with TVarData(Value) do
    case iFldType of
      fldZSTRING:
        Result := VString;
      fldUNICODE:
        Result := VOleStr;
      fldINT16, fldUINT16:
        Result := @VSmallInt;
      fldINT32:
        Result := @VInteger;
      fldBOOL:
        Result := @VBoolean;
      fldTIMESTAMP, fldDATE, fldTIME:
        Result := @VDate;
      fldFLOAT:
        Result := @VDouble;
    else
      Result := nil;
    end;
end;

function AttrComp(Str1, Str2: PChar): Integer;
var
  c1, c2: Char;
begin
  Result := 0;
  repeat
    repeat
      c1 := Str1^;
      Inc(Str1);
    until c1 <> ' ';
    
    repeat
      c2 := Str2^;
      Inc(Str2);
    until c2 <> ' ';

    if c1 > c2 then
      Result := 1
    else if c1 < c2 then
      Result := -1;
  until (Result <> 0) or (c1 = #0);
end;

end.