provider.pas

这是不可多得的源代码

{ TCustomPacketWriter }

constructor TCustomPacketWriter.Create;
begin
  SetLength(FBuffer, DEFBUFSIZE);
end;

destructor TCustomPacketWriter.Destroy;
begin
  FIDSWriter := nil;
  FBuffer := nil;
  inherited Destroy;
end;

procedure TCustomPacketWriter.Check(Status: Integer);
var
  ErrMsg: array[0..2048] of Char;
begin
  if Status <> 0 then
  begin
    FIDSWriter.GetErrorString(Status, ErrMsg);
    raise EDSWriter.Create(ErrMsg, Status);
  end;
end;

procedure TCustomPacketWriter.AddAttribute(Area: TPcktAttrArea; const ParamName: string;
  const Value: OleVariant; IncludeInDelta: Boolean);
const
  ParamTypeMap: array[varSmallInt..varByte] of Integer =
    ( dsfldINT, dsfldINT, dsfldFLOATIEEE, dsfldFLOATIEEE, dsfldBCD,
      dsfldFLOATIEEE, dsfldZSTRING, 0, 0, dsfldBOOL, 0, 0, 0, 0, 0, dsfldINT);
  ParamTypeSize: array[varSmallInt..varByte] of Integer =
    ( SizeOf(SmallInt), SizeOf(Integer), SizeOf(Single), SizeOf(Double),
      SizeOf(Currency), SizeOf(TDateTime), 0, 0, 0, SizeOf(WordBool), 0, 0, 0,
      0, 0, SizeOf(Byte));
var
  ParamType, ParamLen, ElemSize, ElemCount: DWord;
  P: Pointer;
  DateRec: TDateTimeRec;
  TimeStamp: TTimeStamp;
begin
  if ((VarType(Value) and varTypeMask) in [varSmallInt, varInteger, varSingle,
      varDouble, varCurrency, varDate, varOleStr, varBoolean, varByte, varNull]) 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(FBuffer)^ := ParamLen;
      Inc(ParamLen, SizeOf(Word));
      StrPLCopy(@FBuffer[SizeOf(Word)], Value, Length(FBuffer) - SizeOf(Word) - 1);
    end else
    if ParamType = dsfldTIMESTAMP then
    begin
      TimeStamp := DateTimeToTimeStamp(Value);
      DateRec.DateTime := TimeStampToMSecs(TimeStamp);
      Move(DateRec, PChar(FBuffer)^, ParamLen);
      ParamType := ParamType shl dsSizeBitsLen or SizeOf(TDateTimeRec);
    end else
    if ParamType = dsfldDATETIME then
    begin
      P := @TVarData(Value).VPointer;
      Move(P^, PByte(FBuffer)^, ParamLen);
      ParamType := (ParamType shl dsSizeBitsLen) or SizeOf(TSQLTimeStamp);
    end else
    if VarIsArray(Value) then
    begin
      if ParamLen = 0 then
        raise EDSWriter.Create(SInvalidOptParamType, 0);
      ElemCount := VarArrayHighBound(Value, 1) + 1;
      ElemSize := ParamLen;
      if ParamType in [dsfldINT, dsfldUINT] then
        ParamType := (dsfldUINT shl dsSizeBitsLen) or dsArrayFldType or ElemSize
      else
        ParamType := (dsfldBYTES shl dsSizeBitsLen) or dsArrayFldType or ElemSize;
      PInteger(FBuffer)^ := ElemCount;
      ParamLen := ElemCount * ElemSize;
      P := VarArrayLock(Value);
      try
        Move(P^, FBuffer[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(FBuffer)^, ParamLen);
      ParamType := ParamType shl dsSizeBitsLen or ParamLen;
    end;
    if IncludeInDelta then
      ParamType := ParamType or dsIncInDelta;
    Check(FIDSWriter.AddAttribute(Area, PChar(ParamName), ParamType, ParamLen, PByte(FBuffer)));
  end else
    raise EDSWriter.Create(SInvalidOptParamType, 0);
end;

{ TDataPacketWriter }

destructor TDataPacketWriter.Destroy;
begin
  FreeInfoRecords(FPutFieldInfo);
  FPutFieldInfo := nil;
  inherited Destroy;
end;

procedure TDataPacketWriter.FreeInfoRecords(var Info: TInfoArray);
var
  i: Integer;
begin
  for i := 0 to High(Info) do
    if Info[i].FieldInfos <> nil then
    begin
      FreeInfoRecords(TInfoArray(Info[i].FieldInfos));
      TInfoArray(Info[i].FieldInfos) := nil;
    end;
end;

{ Writing data }

procedure TDataPacketWriter.PutBlobField(Info: PPutFieldInfo);
begin
  if not (poFetchBlobsOnDemand in Options) then
  begin
    Info.Size := Info.DataSet.GetBlobFieldData(Info.FieldNo, TBlobByteData(FBuffer));
    if Info.Size <> 0 then
    begin
      if Length(FBuffer) <= Info.Size then
        SetLength(FBuffer, Info.Size + 1);
      FBuffer[Info.Size] := 0;
      if TBlobField(Info.Field).Transliterate then
        Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False);
      FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer))
    end else
      FIDSWriter.PutField(fldIsNull, 0, nil);
  end else
    FIDSWriter.PutField(fldIsChanged, dsDELAYEDBIT or 1, @Info.Size);
end;

procedure TDataPacketWriter.PutCalcField(Info: PPutFieldInfo);
begin
  if Info.DataSet.GetFieldData(Info.Field, FBuffer) then
  begin
    if (Info.Field is TStringField) then
      if TStringField(Info.Field).Transliterate then
        Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False) else
        Info.Size := StrLen(PChar(FBuffer));
    FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer));
  end else
    FIDSWriter.PutField(fldIsNull, 0, nil);
end;

procedure TDataPacketWriter.PutField(Info: PPutFieldInfo);
begin
  if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
    FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer)) else
    FIDSWriter.PutField(fldIsNull, 0, nil);
end;

procedure TDataPacketWriter.PutStringField(Info: PPutFieldInfo);
begin
  if Length(FBuffer) <= Info.Size then
    SetLength(FBuffer, Info.Size + 1);
  if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
  begin
    if TStringField(Info.Field).Transliterate then
      Info.Size := Info.DataSet.Translate(PChar(FBuffer), PChar(FBuffer), False) else
      Info.Size := StrLen(PChar(FBuffer));
    FIDSWriter.PutField(fldIsChanged, Info.Size, PByte(FBuffer));
  end else
    FIDSWriter.PutField(fldIsNull, 0, nil);
end;

procedure TDataPacketWriter.PutWideStringField(Info: PPutFieldInfo);
var
  W: WideString;
begin
  if Info.DataSet.GetFieldData(Info.field, @W, False) then
  begin
    Info.Size := Length(W);
    FIDSWriter.PutField(fldIsChanged, Info.Size * 2, PByte(W));
  end else
    FIDSWriter.PutField(fldIsNull, 0, nil);
end;

procedure TDataPacketWriter.PutVarBytesField(Info: PPutFieldInfo);
begin
  if Info.DataSet.GetFieldData(Info.FieldNo, FBuffer) then
    FIDSWriter.PutField(fldIsChanged, PWord(FBuffer)^, @FBuffer[SizeOf(Word)]) else
    FIDSWriter.PutField(fldIsNull, 0, nil);
end;

procedure TDataPacketWriter.PutADTField(Info: PPutFieldInfo);
var
  i: Integer;
begin
  if Info.Field.IsNull then
    FIDSWriter.PutField(fldIsNull, 0, nil) else
    FIDSWriter.PutField(fldIsChanged, 0, nil);
  for i := 0 to High(TInfoArray(Info.FieldInfos)) do
    with TInfoArray(Info^.FieldInfos)[i] do
      PutProc(@TInfoArray(Info.FieldInfos)[i]);
end;

procedure TDataPacketWriter.PutArrayField(Info: PPutFieldInfo);

  procedure RefreshInfos(Src: TField; Dest: PPutFieldInfo);
  var
    i: Integer;
  begin
    with Dest^ do
    begin
      Field := Src;
      FieldNo := Src.FieldNo;
      if (FieldInfos <> nil) then { Must be an ADT }
      begin
        if not (Src is TADTField) then
          raise EDSWriter.CreateFmt(SArrayElementError,[Src.ClassName]);
        with (Src as TADTField) do
          for i := 0 to FieldCount - 1 do
            RefreshInfos(Fields[i], @TInfoArray(FieldInfos)[i]);
      end;
    end;
  end;

var
  i: Integer;
begin
  if Info.Field.IsNull then
    FIDSWriter.PutField(fldIsNull, 0, nil) else
    FIDSWriter.PutField(fldIsChanged, 0, nil);
  for i := 0 to TArrayField(Info.Field).FieldCount - 1 do
    with TInfoArray(Info^.FieldInfos)[0] do
    begin
      RefreshInfos(TArrayField(Info.Field).Fields[i], @TInfoArray(Info.FieldInfos)[0]);
      PutProc(@TInfoArray(Info.FieldInfos)[0]);
    end;
end;

procedure TDataPacketWriter.PutDataSetField(Info: PPutFieldInfo);
var
  Count: DWord;
  DataSet: TDataSet;
begin
  if Info.Field <> nil then
  begin
    if Info.Field.IsNull then
    begin
      FIDSWriter.PutField(fldIsNull, 0, nil);
      Exit;
    end;
    DataSet := TDataSetField(Info.Field).NestedDataSet;
  end else
    DataSet := Info.DataSet;
  if (poFetchDetailsOnDemand in Options) then
    Count := dsDELAYEDBIT else
    Count := DWord(-1);
  FIDSWriter.PutField(fldIsChanged, SizeOf(Count), @Count);
  if (not (poFetchDetailsOnDemand in Options)) and (Count = DWord(-1)) then
  begin
    DataSet.UpdateCursorPos;
    DataSet.First;
    DataSet.BlockReadSize := MaxInt;
    try
      WriteDataSet(DataSet, TInfoArray(Info.FieldInfos), -1);
      FIDSWriter.EndOfNestedRows;
    finally
      DataSet.BlockReadSize := 0;
    end;
  end;
end;

function TDataPacketWriter.WriteDataSet(DataSet: TDataSet; var Info: TInfoArray;
  RecsOut: Integer): Integer;
const
  B: Byte = 0;
var
  i: Integer;
  ChildOpened: Boolean;

  function OpenCloseDetails(Info: TInfoArray; ActiveState: Boolean): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := 0 to High(Info) do
    begin
      if Info[I].IsDetail and (Info[I].DataSet.Active <> ActiveState) then
      begin
        Info[I].DataSet.Active := ActiveState;
        Info[I].Opened := ActiveState;
        Result := True;
      end;
    end;
  end;

begin
  Result := 0;
  if RecsOut = AllRecords then
    RecsOut := High(Integer);
  if DataSet.DefaultFields then
    RefreshPutProcs(DataSet, Info);
  ChildOpened := OpenCloseDetails(Info, True);
  while (not DataSet.EOF) and (Result < RecsOut) do
  begin
    FIDSWriter.PutField(fldIsChanged, 1, @B);
    for i := 0 to High(Info) do
      Info[i].PutProc(@Info[i]);
    Inc(Result);
    if Result < RecsOut then
      DataSet.Next;
  end;
  if ChildOpened then
    OpenCloseDetails(Info, False);
end;

{ Writing meta data }

procedure TDataPacketWriter.AddDataSetAttributes(DataSet: TDataSet);
var
  i: Integer;
  List: TList;
begin
  if Assigned(FOnGetParams) then
  begin
    List := TList.Create;
    try
      FOnGetParams(DataSet, List);
      for i := 0 to List.Count - 1 do
        with PPacketAttribute(List[i])^ do
        begin
          AddAttribute(pcktAttrArea, Name, Value, IncludeInDelta);
          Dispose(PPacketAttribute(List[i]));
        end;
    finally
      List.Free;