memtableeh.pas

ehlib31控件包

procedure TMemoryRecordEh.SetIndex(Value: Integer);
var
  CurIndex: Integer;
begin
  CurIndex := GetIndex;
  if (CurIndex >= 0) and (CurIndex <> Value) then
    FRecordsList.Move(CurIndex, Value);
end;

procedure TMemoryRecordEh.RevertRecord;
begin
  case FUpdateStatus of
    usModified:
      begin
        Dispose(FData);
        FData := FOldData;
        FOldData := nil;
        FUpdateStatus := usUnmodified;
        RecordsList.Notify(Self, Index, rlnRecChangedEh);
      end;
    usDeleted:
      begin
        FUpdateStatus := usUnmodified;
        RecordsList.Notify(Self, Index, rlnRecChangedEh);
      end;
  end;
end;

procedure TMemoryRecordEh.RefreshRecord(RecValues: TRecDataValues);
begin
  if FUpdateStatus = usModified
    then FOldData^ := RecValues
    else FData^ := RecValues;
end;

procedure TMemoryRecordEh.SetUpdateStatus(const Value: TUpdateStatus);
begin
  FUpdateStatus := Value;
end;

{ TCustomMemTableEh }

constructor TCustomMemTableEh.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRecordPos := -1;
  FInstantReadCurRow := -1;
  FAutoInc := 1;
  FRecords := TFilteredRecordsListEh.Create(Self);
  FMasterDataLink := TMasterDataLinkEh.Create(Self);
  FMasterDataLink.OnMasterChange := MasterChange;
  FDetailFieldList := TList.Create;
  FParams := TParams.Create(Self);
end;

destructor TCustomMemTableEh.Destroy;
begin
  Close;
  FParams.Free;
  FDetailFieldList.Clear;
  FDetailFieldList.Free;
  ClearRecords;
  FRecords.Free;
  FMasterDataLink.Free;
  inherited Destroy;
end;

{ Field Management }

{$IFNDEF EH_LIB_5}

function TCustomMemTableEh.BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean;
begin
  Move(BCD^, Curr, SizeOf(Currency));
  Result := True;
end;

function TCustomMemTableEh.CurrToBCD(const Curr: Currency; BCD: Pointer; Precision,
  Decimals: Integer): Boolean;
begin
  Move(Curr, BCD^, SizeOf(Currency));
  Result := True;
end;

{$ENDIF EH_LIB_5}

procedure TCustomMemTableEh.InitFieldDefsFromFields;
var
  I: Integer;
begin
  if FieldDefs.Count = 0 then
  begin
    for I := 0 to FieldCount - 1 do
    begin
      with Fields[I] do
        if (FieldKind in fkStoredFields) and not (DataType in ftSupported) then
          ErrorFmt(SUnknownFieldType, [DisplayName]);
    end;
//    FreeIndexList;
  end;

  inherited InitFieldDefsFromFields;
end;

function TCustomMemTableEh.FindFieldData(Buffer: Pointer; Field: TField): Pointer;
//var
//  Index: Integer;
begin
{ddd  Index := FieldDefList.IndexOf(Field.FullName);
  if (Index >= 0) and (Buffer <> nil) and
    (FieldDefList[Index].DataType in ftSupported - ftBlobTypes) then
    Result := (PChar(Buffer) + FOffsets[Index])
  else Result := nil;
}
{  if (Buffer <> nil)
    then Result := PRecValues(Buffer)^[Field.FieldNo]
    else Result := nil;}
  Result := nil;
end;

{ Buffer Manipulation }

procedure TCustomMemTableEh.InitBufferPointers(GetProps: Boolean);
begin
  if GetProps then
    FDataRecordSize := (Fields.Count * SizeOf(OleVariant));

  FRecBufSize := SizeOf(TRecInfo) + (Fields.Count * SizeOf(Pointer));
end;

procedure TCustomMemTableEh.ClearRecords;
begin
  FRecords.FRecordsList.Clear;
  FRecordPos := -1;
  FInstantReadCurRow := -1;
end;

function TCustomMemTableEh.AllocRecordBuffer: PChar;
var
  RecBuf: PRecBuf;
  I: Integer;
begin
  New(RecBuf);
  SetLength(RecBuf^.Values, FieldCount);
  for I := 0 to Fields.Count - 1 do
    RecBuf^.Values[I].IsNull := True;
  RecBuf^.RecInfo.RecordStatus := -1;
  Result := PChar(RecBuf);
end;

procedure TCustomMemTableEh.FreeRecordBuffer(var Buffer: PChar);
var
  RecBuf: PRecBuf;
begin
  RecBuf := PRecBuf(Buffer);
  SetLength(RecBuf^.Values, 0);
  Dispose(RecBuf);
  Buffer := nil;
end;

procedure TCustomMemTableEh.ClearCalcFields(Buffer: PChar);
var
  I: Integer;
begin
  if CalcFieldsSize > 0 then
    for I := 0 to Fields.Count - 1 do
      with Fields[I] do
        if FieldKind in [fkCalculated, fkLookup] then
          PRecBuf(Buffer)^.Values[Offset + DataFieldsCount].IsNull := True;
end;

procedure TCustomMemTableEh.InternalInitRecord(Buffer: PChar);
var
  I: Integer;
begin
  for I := 0 to Fields.Count - 1 do
    PRecBuf(Buffer)^.Values[I].IsNull := True;
end;

procedure TCustomMemTableEh.InitRecord(Buffer: PChar);
begin
  inherited InitRecord(Buffer);

  with PRecBuf(Buffer)^.RecInfo do
  begin
    Bookmark := Low(TRecIdEh);
    BookmarkFlag := bfInserted;
//    RecordStatus := 0;
    RecordNumber := FRecordPos;
  end;
end;

function TCustomMemTableEh.GetCurrentRecord(Buffer: PChar): Boolean;
begin
  Result := False;
{  if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then
  begin
    UpdateCursorPos;
    if (FRecordPos >= 0) and (FRecordPos < RecordCount) then
    begin
      Move(FRecords[FRecordPos]^, Buffer^, FDataRecordSize);
      Result := True;
    end;
  end;
}
end;

procedure TCustomMemTableEh.RecordToBuffer(Rec: PRecValues; Buffer: PChar);
var
  i: Integer;
begin

  with PRecBuf(Buffer)^.RecInfo do
  begin
//    RecordStatus := 0; //Recordset.Status;
    BookmarkFlag := bfCurrent;
//    Bookmark := FRecordPos;
  end;

  // Don't need assign data values
  // Will do in on first SetFieldData
  for i := 0 to FieldCount-1 do
    if Fields[i].FieldNo > 0 then
//      VarValueToFieldValue(Rec^[Fields[i].FieldNo-1], @(PRecBuf(Buffer)^.Values[i]), Fields[i]);
      VarValueToFieldValue(Rec^[Fields[i].FieldNo-1], @(PRecBuf(Buffer)^.Values[Fields[i].FieldNo-1]), Fields[i]);


  GetCalcFields(Buffer);
end;

procedure TCustomMemTableEh.CopyBuffer(FromBuf, ToBuf: PChar);
var
  i:Integer;
begin
  PRecBuf(ToBuf)^.RecInfo := PRecBuf(FromBuf)^.RecInfo;
  SetLength(PRecBuf(ToBuf)^.Values, Length(PRecBuf(FromBuf)^.Values));
  for i := 0 to Length(PRecBuf(FromBuf)^.Values)-1 do
  begin
    PRecBuf(ToBuf)^.Values[i].IsNull := PRecBuf(FromBuf)^.Values[i].IsNull;
    SetString(PRecBuf(ToBuf)^.Values[i].DataValue,
      PChar(PRecBuf(FromBuf)^.Values[i].DataValue),
      Length(PRecBuf(FromBuf)^.Values[i].DataValue));
  end;
end;

procedure TCustomMemTableEh.VarValueToFieldValue(VarValue: Variant; FieldBuffer: Pointer; Field: TField);

var
  FieldValBuf: PFieldValBuf;
  DataValueBuf: Pointer;
  StrVal: String;

  procedure CurrToBuffer(const C: Currency);
  begin
    Currency(DataValueBuf^) := C;
  end;

begin
  FieldValBuf := PFieldValBuf(FieldBuffer);
  FieldValBuf.IsNull := False;
  if VarIsNull(VarValue) then
    FieldValBuf.IsNull := True
  else
  begin
    SetLength(FieldValBuf.DataValue, Field.DataSize);
//    SetString(FieldValBuf.DataValue, Field.DataSize);
    DataValueBuf := PChar(FieldValBuf.DataValue);
//    GetMem(FieldBuffer, Field.DataSize);
    case Field.DataType of
      ftGuid, ftFixedChar, ftString:
        StrPLCopy(PChar(DataValueBuf), VarToStr(VarValue), Field.Size);
//        SetString(FieldValBuf.DataValue, PChar(VarToStr(VarValue)), Field.Size);
      ftWideString:
        WideString(DataValueBuf^) := VarValue;
      ftSmallint:
        SmallInt(DataValueBuf^) := VarValue;
      ftWord:
        Word(DataValueBuf^) := VarValue;
      ftAutoInc, ftInteger:
        Integer(DataValueBuf^) := VarValue;
      ftFloat, ftCurrency:
        Double(DataValueBuf^) := VarValue;
      ftBCD:
        CurrToBuffer(VarValue);
      ftBoolean:
        WordBool(DataValueBuf^) := VarValue;
      ftDate, ftTime, ftDateTime:
        DataConvert(Field, @TVarData(VarValue).VDate, DataValueBuf, True);
      ftBytes, ftVarBytes:
        DataConvert(Field, @TVarData(VarValue).VDate, DataValueBuf, True);
      ftInterface: IUnknown(DataValueBuf^) := VarValue;
      ftIDispatch: IDispatch(DataValueBuf^) := VarValue;
{$IFDEF EH_LIB_6}
      ftLargeInt: LargeInt(DataValueBuf^) := VarValue;
{$ENDIF}
      ftBlob..ftTypedBinary, ftOraBlob, ftOraClob:
      begin
        StrVal := VarToStr(VarValue);
        SetString(FieldValBuf.DataValue, PChar(StrVal), Length(StrVal));
      end;
      {ftBlob..ftTypedBinary,} ftVariant: Variant(DataValueBuf^) := VarValue;
    else
      DatabaseErrorFmt('SUsupportedFieldType', [FieldTypeNames[Field.DataType],
        Field.DisplayName]);
    end;
  end;
end;

procedure TCustomMemTableEh.FieldValueToVarValue(FieldBuffer: Pointer; var VarValue: Variant; Field: TField);
var
  FieldValBuf: PFieldValBuf;
  DataValueBuf: Pointer;
  DateVal: TDateTime;
  CurrencyVal: Currency;
  StrVal: String;
begin
  FieldValBuf := PFieldValBuf(FieldBuffer);
  DataValueBuf := PChar(FieldValBuf.DataValue);

  if FieldValBuf.IsNull then
    VarValue := Null
  else
    case Field.DataType of
      ftString, ftFixedChar, ftGuid:
        VarValue := String(PChar(DataValueBuf));
      ftWideString:
        VarValue := WideString(DataValueBuf^);
      ftAutoInc, ftInteger:
        VarValue := LongInt(DataValueBuf^);
      ftSmallInt:
        VarValue := SmallInt(DataValueBuf^);
      ftWord:
        VarValue := Word(DataValueBuf^);
      ftBoolean:
        VarValue := WordBool(DataValueBuf^);
      ftFloat, ftCurrency:
        VarValue := Double(DataValueBuf^);
      ftBlob..ftTypedBinary, ftOraBlob, ftOraClob:
        begin
          SetString(StrVal, PChar(FieldValBuf.DataValue), Length(FieldValBuf.DataValue));
          VarValue := StrVal;
        end;  
      ftVariant:
        VarValue := Variant(DataValueBuf^);
      ftInterface:
        VarValue := IUnknown(DataValueBuf^);
      ftIDispatch:
        VarValue := IDispatch(DataValueBuf^);
      ftDate, ftTime, ftDateTime:
        begin
          DataConvert(Field, DataValueBuf, @DateVal, False);
          VarValue := DateVal;
        end;
      ftBCD:
        begin
          DataConvert(Field, DataValueBuf, @CurrencyVal, False);
          VarValue := CurrencyVal;
        end;
      ftBytes, ftVarBytes:
        DataConvert(Field, DataValueBuf, @VarValue, False);
      ftLargeInt:
{$IFDEF EH_LIB_6}
        VarValue := Int64(DataValueBuf^);
{$ENDIF}
      else
        DatabaseErrorFmt('SUnsupportedFieldType', [FieldTypeNames[Field.DataType],
          Field.DisplayName]);
    end;
end;

function TCustomMemTableEh.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
//var
//  Accept: Boolean;
begin
  Result := grOk;
//  Accept := True;
  case GetMode of
    gmPrior:
      if FRecordPos <= 0 then
      begin
        Result := grBOF;
        FRecordPos := -1;
        FInstantReadCurRow := 0;
      end else
        Dec(FRecordPos);
    gmCurrent:
      if (FRecordPos < 0) or (FRecordPos >= FRecords.Count) then
        Result := grError;
    gmNext:
      begin
        if FRecordPos >= FRecords.Count - 1 then
          if FetchAllOnOpen
            then DoFetchRecords(-1)
            else DoFetchRecords(1);
        if FRecordPos >= FRecords.Count - 1 then
        begin
          FRecordPos := FRecords.Count;
          Result := grEOF
        end else
          Inc(FRecordPos);
      end;
  end;
  if FRecordPos >= 0 then
    FInstantReadCurRow := FRecordPos;
  if Result = grOk then
  begin
    RecordToBuffer(FRecords[FRecordPos].Data, Buffer);
    PRecBuf(Buffer)^.RecInfo.Bookmark := FRecords[FRecordPos].ID;
    PRecBuf(Buffer)^.RecInfo.RecordNumber := FRecordPos;
  end else if (Result = grError) and DoCheck then
    Error(SMemNoRecords);
end;

function TCustomMemTableEh.GetRecordSize: Word;
begin
  Result := FRecBufSize;
//  Result := FDataRecordSize;
end;