hbcore.pas

Midas.dll全部源码

  end;
end;

procedure TDSBase.CreateEmbeddedDS(Index: Integer);
var
  DSBase: IDSBase;
  DSBaseA: TDSBase;
begin
  DSBase  := CreateDSBase;
  DSBaseA := BaseFromIDS(DSBase);
  SetLength(FChilds, Length(FChilds) + 1);
  FChilds[High(FChilds)] := DSBase;
  DSBaseA.FParentDS := Self;
  DSBaseA.FParentFieldNo := Index + 1;
end;

function TDSBase.GetEmbeddedDS(iFieldID: DWord; out DsDet: IDSBase): DBResult;
var
  I, J: DWord;
begin
  try
    J := 0;
    for I := 0 to High(FFields) do
      if FFields[I].iFldType = fldTABLE then
      begin
        if I + 1 = iFieldID then
        begin
          DsDet := FChilds[J];
          Break;
        end;
        Inc(J);
      end else if (FFields[I].iFldAttr and fldAttrLink) <> 0 then
        Dec(iFieldID);
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.GetEmbeddedDSBase(iFieldNo: DWord): TDSBase;
var
  DSBase: IDSBase;
begin
  Check(GetEmbeddedDS(iFieldNo, DsBase));
  Result := BaseFromIDS(DSBase);
end;

function TDSBase.GetEmbeddedDSBaseByDescNo(DescNo: Integer): TDSBase;
var
  I, J: Integer;
  DsDet: IDSBase;
begin
  J := 0;
  for I := 0 to High(FWFldDescs) do
  begin
    if PacketFieldType(FWFldDescs[I].FldDes.iFieldType) = dsfldEMBEDDEDTBL then
    begin
      if I = DescNo then
      begin
        DsDet := FChilds[J];
        Break;
      end;
      Inc(J);
    end;
  end;
  Result := BaseFromIDS(DsDet);
end;

function TDSBase.MakeEmbedded(DsDet: IDSBase; iFieldsLink: DWord;
  piFieldsM, piFieldsD: PDWord; pMasterFieldName,
  pDetailFieldName: PChar): DBResult;
begin
  Result := DBERR_NIY;
end;

function TDSBase.GetParentSeqNo(pRecBuf: PChar): DWord;
var
  bBlank: Bool;
  I: Integer;
  RecNo: Integer;
begin
  if Assigned(FParentDS) then
  begin
    GetField(pRecBuf, FLinkFieldNo, @RecNo, bBlank);
    with FParentDS.FRecords do
      for I := Count - 1 downto 0 do
      begin
        pRecBuf := List^[I];
        if GetRecordRecNo(pRecBuf) = RecNo then
        begin
          Result := I;
          Exit;
        end;
      end;
  end;
  Result := DWord(-1);
end;

function TDSBase.GetErrorString(iErrCode: DBResult; pString: PChar): DBResult;
begin
  try
    if (iErrCode = DBERR_CONSTRAINTFAILED) then
      StrCopy(pString, PChar(FConstrErrorMsg))
    else
      GetErrorMessage(iErrCode, pString);
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.GetIndexDescs(p1: PDSIDXDesc): DBResult;
begin
  Move(Pointer(FIndexes)^, p1^, (High(FIndexes) + 1) * SizeOf(DSIDXDesc));
  Result := DBERR_NONE;
end;

function TDSBase.AddOptParameter(iFldNo: DWord; pszAttr: PChar; iType,
  iLen: DWord; pValue: Pointer): DBResult;
var
  Value: PChar;
begin
  try
    // String parameters begin from the length word.
    if (((iType and dsTypeBitsMask) shr dsSizeBitsLen) = dsfldZSTRING) then
    begin
      GetMem(Value, iLen + SizeOf(Word));
      try
        PWord(Value)^ := iLen;
        StrCopy(Value + SizeOf(Word), pValue);
        hbUtils.AddOptAttribute(FAttrInfos, iFldNo, pszAttr, iType, iLen + SizeOf(Word), Value);
      finally
        FreeMem(Value);
      end;
    end else begin
      if iType and (dsfldBYTES shl dsSizeBitsLen) <> 0 then
      begin
        GetMem(Value, iLen + SizeOf(Integer));
        try
          PInteger(Value)^ := iLen;
          Move(pValue^, (Value + SizeOf(Integer))^, iLen);
          hbUtils.AddOptAttribute(FAttrInfos, iFldNo, pszAttr, iType, iLen + SizeOf(Integer), Value);
        finally
          FreeMem(Value);
        end;
      end else
        hbUtils.AddOptAttribute(FAttrInfos, iFldNo, pszAttr, iType, iLen, pValue);
    end;

    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.GetOptParameter(iNo, iFldNo: DWord; var ppName: Pointer;
  var piType, piLen: DWord; var ppValue: Pointer): DBResult;
begin
  Result := hbUtils.GetOptAttribute(FAttrInfos, iNo, iFldNo, ppName, piType, piLen, ppValue);
  // String parameters begin from the length word.
  if (((piType and dsTypeBitsMask) shr dsSizeBitsLen) = dsfldZSTRING) then
  begin
    Inc(PChar(ppValue), SizeOf(Word));
    Dec(piLen, SizeOf(Word));
  end;
end;

function TDSBase.GetProp(eProp: DSProp; piPropValue: Pointer): DBResult;
begin
  case eProp of
    dspropLOGCHANGES:
      PBool(piPropValue)^ := FLogChanges;
    dspropREADONLY:
      PBool(piPropValue)^ := FReadOnly;
    dspropNOOFCHANGES:
      PInteger(piPropValue)^ := FChangeCount;//FChangesAll.Count div 2;
    dspropCONSTRAINTS_DISABLED:
      PBool(piPropValue)^ := FConstrDisabled;
    dspropDSISPARTIAL:
      PBool(piPropValue)^ := FDSIsPartial;
    dspropRECORDSINDS:
      PInteger(piPropValue)^ := FRecords.Count;
    dspropAUTOINC_DISABLED:
      PBool(piPropValue)^ := FAutoIncDisabled;
    dspropISDELTA:
      PBool(piPropValue)^ := FIsDelta;
    dspropDONTINCLMETADATA:
      PBool(piPropValue)^ := FNoMetaData;
    dspropINCLBLOBSINDELTA:
      pDWord(piPropValue)^ := FBlobsInDelta;
    dspropGETSAVEPOINT:
      PInteger(piPropValue)^ := FChangesDS.Count;
    dspropCOMPRESSARRAYS:
      ;
    dspropMD_SEMANTICS:
      PDWord(piPropValue)^ := FMDOptions;
    dspropFIELD_FULLNAME:
      ;
    dspropFIELDID_FORNAME:
      ;
    dspropFIELDID_FORPARENT:
      ;
    dspropCHANGEINDEX_VIEW:
      ;
    dspropGETUNIQUEINDEX:
      ;
    dspropREMOTE_UPDATEMODE:
      ;
    dspropXML_STREAMMODE:
      PDWord(piPropValue)^ := FXMLStreamMode;
    else if eProp = DSProp(-1) then
      TDSBase(piPropValue^) := Self;
  end;
  Result := DBERR_NONE;
end;

function TDSBase.GetProps(var Prop: DSProps): DBResult;
var
  TmpFields: DSFLDDescList;
begin
  try
    ZeroMem(@Prop, SizeOf(DSProps));
    with Prop do
    begin
      StrCopy(szName, PChar(FName));
      GetFieldDescList(TmpFields, False, False);
      iFields          := Length(TmpFields);
      iRecBufSize      := FRecBufSize;
      iBookMarkSize    := SizeOf(DSBOOKMRK);
      bReadOnly        := FReadOnly or FStreamedReadOnly;
      iIndexes         := Length(FIndexes);
      iOptParams       := Length(FAttrInfos);
      bDelta           := FIsDelta;
      iLCID            := FLCID;
    end;
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.GetFieldDescs(Fields: pDSFLDDesc): DBResult;
var
  TmpFields: DSFLDDescList;
begin
  try
    GetFieldDescList(TmpFields, False, False);
    Move(Pointer(TmpFields)^, Fields^, Length(TmpFields) * SizeOf(DSFLDDesc));
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

procedure TDSBase.PutBlankParent(pRecBuf: PChar; iFldNo: DWord);
var
  I: Integer;
  iBlankValue: DWord;
begin
  with FFields[iFldNo - 1] do
  begin
    iBlankValue := BLANK_NULL;

    for I := iFldNo to iFldNo + DWord(iUnits1) do
      with FFields[I] do
        if (PChar(pRecBuf) + iNullOffsInRec)^ = Char(NOT_BLANK) then
        begin
          iBlankValue := NOT_BLANK;
          Break;
        end;

    PutBlankInternal(pRecBuf, iFldNo, iBlankValue);

    if (iBlankValue = NOT_BLANK) and (iFieldIDParent <> 0) then
      PutBlankParent(pRecBuf, iFieldIDParent);
  end;
end;

procedure TDSBase.PutBlankValues(pRecBuf: Pointer; iFldNo, iBlankValue: DWord);
var
  I: Integer;
begin
  with FFields[iFldNo - 1] do
  begin
    if (iFldType = fldBLOB) and (iBlankValue <> NOT_BLANK) then
      PutBlobInternal(pRecBuf, iFldNo, 0, nil, 0);

    PutBlankInternal(pRecBuf, iFldNo, iBlankValue);

    if (iFieldIDParent <> 0) then
      PutBlankParent(pRecBuf, iFieldIDParent);

    { Clear children }
    if (iFldType in [fldADT, fldARRAY]) and (iBlankValue <> NOT_BLANK) then
      for I := iFldNo to iFldNo + DWord(iUnits1) do
        PutBlankValues(pRecBuf, I + 1, iBlankValue);
  end;
end;

procedure TDSBase.PutBlankInternal(pRecBuf: Pointer; iFldNo, iBlankValue: DWord);
begin
  with FFields[iFldNo - 1] do
    (PChar(pRecBuf) + iNullOffsInRec)^ := Char(iBlankValue);
end;

function TDSBase.PutBlank(pRecBuf: Pointer; iRecNo, iFldNo, iBlankValue: DWord): DBResult;
begin
  try
    if not Assigned(pRecBuf) then
      pRecBuf := GetRecordPtr(iRecNo);
    PutBlankValues(pRecBuf, iFldNo, iBlankValue);
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSBase.GetResponses(DeltaDS, ErrorDS: TDSBase; FieldNums: TList;
  iClientData: DWord; pfReconcile_MD: pfDSReconcile_MD): Boolean;
var
  iRslt         : dsCBRType;  { Result of previous callback. If set, the previuos parameters are repeated. }
  iAction       : DSAttr;   { Update request Insert/Modify/Delete }

  pRecBuf       : PChar;

  pRecUpd       : PChar;    { Record that failed update }
  pRecOrg       : PChar;    { Original record, if any }
  pRecConflict  : PChar;    { Conflicting error, if any }

  iErrResponse  : dsCBRType; { Resolver response }
  iErrCode      : Integer;  { Native error-code, (BDE or ..) }
  pErrMessage   : array[0..MAXMSGLEN + 1] of Char;
  pErrContext   : array[0..MAXMSGLEN + 1] of Char;

  ErrorCur, DeltaCur: TDSCursor;

  I, DeltaRecNo: Integer;
  Child, DeltaD, ErrorD: TDSBase;

  HasConflicts: Boolean;

  bBlank: Bool;
begin
  Result := True;

  if not Assigned(FResponses) then
  begin
    FResponses := TList.Create;
    FResponses.Capacity := ErrorDS.FRecords.Count * 2;
  end;

  if Assigned(FParentDS) then
    FieldNums.Add(Pointer(FParentFieldNo));

  DeltaCur := CursorFromIDS(DeltaDS.FRCursor);
  ErrorCur := CursorFromIDS(ErrorDS.FRCursor);

  iRslt := 0;

  AllocRecord(pRecConflict);
  try
    while ErrorCur.MoveRelative(1) <> DBERR_EOF do
    begin
      with ErrorCur do
      begin
        GetCurrentRecordPtr(pRecBuf);
        GetField(pRecBuf, 1, @DeltaRecNo, bBlank);
      end;

      Check(DeltaCur.MoveToSeqNo(DeltaRecNo));

      // Process detail datasets
      for I := 0 to High(FChilds) do
      begin
        Child   := BaseFromIDS(FChilds[I]);
        DeltaD  := BaseFromIDS(DeltaDS.FChilds[I]);
        ErrorD  := BaseFromIDS(ErrorDs.FChilds[I]);
        Result  := Child.GetResponses(DeltaD, ErrorD, FieldNums, iClientData, pfReconcile_MD);
        if not Result then Exit;
      end;

      with ErrorCur do
      begin
        GetField(pRecBuf, 2, @iErrResponse, bBlank);
        // Only detail records have errors
        if bBlank then Continue;
        GetField(pRecBuf, 3, @pErrMessage,  bBlank);
        GetField(pRecBuf, 4, @pErrContext,  bBlank);
        GetField(pRecBuf, 6, @iErrCode,     bBlank);
      end;

      InitRecord(pRecConflict);

      with ErrorDS do
      begin
        HasConflicts := False;
        for I := 6 to High(FFields) do
          with FFields[I] do
            if (iFldType <> fldTABLE) and ((iFldAttr and fldAttrLink) = 0) and
              ((pRecBuf + iNullOffsInRec)^ <> Char(BLANK_NOTCHANGED)) then
            begin
              HasConflicts := True;
              CopyField(FFields[I], Self.FFields[I - 6], pRecBuf, pRecConflict);
            end;
      end;

      with DeltaCur do
      begin
        GetCurrentRecordPtr(pRecBuf);
        pRecUpd := pRecBuf;

        iAction := GetRecordAttr(pRecBuf) and dsIsModified;

        // Store number of record
        if (iAction in [dsRecNew, dsRecDeleted]) then
          FResponses.Add(FRecNums.List^[FRecPos]) else
          FResponses.Add(FRecNums.List^[FRecPos - 1]);

        if iAction = dsRecNew then