dxmdaset.pas

在Dephi中用于文件的输出

              end;
              if j <> 0 then break;
            end;

          if RealRec = -1 then
            break;
          if j = 0 then
          begin
            Result := i;
            break;
          end;
        end;
      end;
    finally
      for i := 0 to AValueList.Count - 1 do
        FreeMem(Pointer(AValueList[i]));
    end;
  finally
    AFieldList.Free;
    AValueList.Free;
    AmFieldList.Free;
  end;
end;

function TdxMemData.Locate(const KeyFields: string; const KeyValues: Variant;
           Options: TLocateOptions): Boolean;
var
  AIndex: Integer;
begin
  AIndex := InternalLocate(KeyFields, KeyValues, Options);
  Result := AIndex > -1;
  if Result then
  begin
    Inc(AIndex);
    if(RecNo <> AIndex) then
     RecNo := AIndex
    else Resync([]);
  end;
end;

procedure AddStrings(AStrings: TStrings; S: string);
var
  P: Integer;
begin
  repeat
    P := Pos(';', S);
    if P = 0 then
    begin
      AStrings.Add(S);
      Break;
    end
    else
    begin
      AStrings.Add(Copy(S, 1, P - 1));
      Delete(S, 1, P);
    end;
  until False;
end;

function TdxMemData.Lookup(const KeyFields: string; const KeyValues: Variant;
    const ResultFields: string): Variant;

   function GetLookupValue(AField: TField; ALookupIndex: Integer): Variant;
   var
     mField : TdxMemField;
   begin
     if(AField = nil) then
       Result := Null
     else
     begin
      if not (AField is TBlobField) then
      begin
        mField := FData.IndexOf(AField);
        if (mField <> nil) and mField.HasValue[ALookupIndex] then
          Result := GetVariantValue(mField.Values[ALookupIndex], AField)
        else
          Result := Null;
      end
      else
        Result := GetBlobData(TValueBuffer(FBlobList[ALookupIndex]), AField.Offset);
     end;
   end;

var
  FLookupIndex: Integer;
  I: Integer;
  AStrings: TStrings;
begin
  FLookupIndex := InternalLocate(KeyFields, KeyValues, []);
  if (FLookupIndex > -1) then
  begin
    if FIsFiltered then
      FLookupIndex := Integer(TValueBuffer(FFilterList[FLookupIndex])) - 1;
    I := Pos(';', ResultFields);
    if(I < 1) then
      Result := GetLookupValue(FindField(ResultFields), FLookupIndex)
    else
    begin
      AStrings := TStringList.Create;
      try
        AddStrings(AStrings, ResultFields);
        Result := VarArrayCreate([0, AStrings.Count - 1],
          varVariant);
        for I := 0 to AStrings.Count - 1 do
           Result[I] := GetLookupValue(FindField(AStrings[I]), FLookupIndex);
      finally
        AStrings.Free;
      end;
    end;
  end else Result := Null;
end;

function TdxMemData.GetRecNoByFieldValue(Value : Variant; FieldName : String) : Integer;
begin
  Result := InternalLocate(FieldName, Value, []);
  if Result > -1 then
    Inc(Result);
end;

function TdxMemData.SupportedFieldType(AType: TFieldType): Boolean;
begin
  Result := GetNoByFieldType(AType) <> -1;
end;

function TdxMemData.GetFieldClass(FieldType: TFieldType): TFieldClass;
begin
  Result := inherited GetFieldClass(FieldType);
end;

procedure TdxMemData.InternalOpen;
var
  i : Integer;
begin
  for i := 0 to FieldCount - 1 do
    if not SupportedFieldType(Fields[i].DataType) then
    begin
      DatabaseErrorFmt('Unsupported field type: %s', [Fields[i].FieldName]);
      exit;
    end;

  FillBookMarks;

  FCurRec := -1;
  FFilterCurRec := -1;

  FRecInfoOfs := 0;
  for i := 0 to FieldCount - 1 do
    if not Fields[i].IsBlob then
      Inc(FRecInfoOfs, GetDataSize(Fields[i]) + 1);

  FRecBufSize := FRecInfoOfs + SizeOf(TdxRecInfo);
  BookmarkSize := SizeOf(Integer);

  InternalInitFieldDefs;

  if DefaultFields then CreateFields;

  for i := 0 to FieldCount - 1 do
   if not Fields[i].IsBlob then
     FData.Add(Fields[i]);

  FData.FValues := TList.Create;
  BindFields(True);
  FActive := True;
  MakeSort;
  Indexes.CheckFields;
end;

procedure TdxMemData.InternalClose;
begin
  if (csDestroying in ComponentState) then exit;

  FData.Clear;
  FBookMarks.Clear;
  FFilterList.Clear;
  BlobClear;
  FSortedField := nil;

  if DefaultFields then DestroyFields;

  FLastBookmark := 0;
  FCurRec := -1;
  FFilterCurRec := -1;
  FActive := False;
end;

function TdxMemData.IsCursorOpen: Boolean;
begin
  Result := FActive;
end;

procedure TdxMemData.InternalInitFieldDefs;
var
  i : Integer;
begin
  FieldDefs.Clear;
  for i := 0 to FieldCount - 1 do
    with Fields[i] do
      if Calculated or Lookup then
        FData.FCalcFields.Add(Fields[i])
      else
        FieldDefs.Add(FieldName, DataType, Size, Required);
end;

procedure TdxMemData.InternalHandleException;
begin
  HandleException(Self);
end;

procedure TdxMemData.InternalGotoBookmark(Bookmark: TBookmark);
var
  Index, IndexF: Integer;
begin
  Index := FBookMarks.IndexOf(TObject(PInteger(Bookmark)^));
  if Index > -1 then
  begin
    if FIsFiltered then
    begin
      IndexF := FFilterList.IndexOf(TValueBuffer(Index + 1));
      if(IndexF > -1) then
      begin
        FFilterCurRec := IndexF;
        FCurRec := Index;
      end;
    end else FCurRec := Index
  end else
    DatabaseError('Bookmark not found');
end;

procedure TdxMemData.InternalSetToRecord(Buffer: TRecordBuffer);
begin
  InternalGotoBookmark(@PdxRecInfo(Buffer + FRecInfoOfs).Bookmark);
end;

function TdxMemData.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag;
begin
  Result := PdxRecInfo(Buffer + FRecInfoOfs).BookmarkFlag;
end;

procedure TdxMemData.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag);
begin
  PdxRecInfo(Buffer + FRecInfoOfs).BookmarkFlag := Value;
end;

procedure TdxMemData.GetBookmarkData(Buffer: TRecordBuffer; Data: TBookMark);
begin
  PInteger(Data)^ := PdxRecInfo(Buffer + FRecInfoOfs).Bookmark;
end;

procedure TdxMemData.SetBookmarkData(Buffer: TRecordBuffer; Data: TBookmark);
begin
  PdxRecInfo(Buffer + FRecInfoOfs).Bookmark := PInteger(Data)^;
end;

function TdxMemData.GetCurrentRecord(Buffer: TRecordBuffer): Boolean;
begin
  if ActiveBuffer <> nil then
  begin
    CopyData(ActiveBuffer, Buffer, RecordSize);
    Result := True;
  end else Result := False;
end;

function TdxMemData.GetRecordSize: Word;
begin
  Result := FRecInfoOfs;
end;

procedure TdxMemData.Loaded;
begin
  inherited Loaded;
  Indexes.AfterMemdataLoaded;
  if Active and (Persistent.Option = poLoad) then
    Persistent.LoadData;
end;

function TdxMemData.AllocRecordBuffer: TRecordBuffer;
begin
  Result := AllocMem(FRecBufSize + BlobFieldCount * SizeOf(Pointer));
  InitializeBlobData(TRecordBuffer(Integer(Result) + FRecBufSize));
end;

procedure TdxMemData.FreeRecordBuffer(var Buffer: TRecordBuffer);
begin
  FinalizeBlobData(TValueBuffer(Integer(Buffer) + FRecBufSize));
  FreeMem(Buffer);
  Buffer := nil;
end;

function TdxMemData.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  if (FData = nil) then
  begin
    Result := grError;
    exit;
  end;
  if FData.RecordCount < 1 then
    Result := grEOF else
  begin
    Result := grOK;
    if Not FIsFiltered then
      case GetMode of
        gmNext:
          if FCurRec >= RecordCount - 1  then
            Result := grEOF else
            Inc(FCurRec);
        gmPrior:
          if FCurRec <= 0 then
            Result := grBOF else
            Dec(FCurRec);
        gmCurrent:
          if (FCurRec < 0) or (FCurRec >= RecordCount) then
            Result := grError;
        else GetCalcFields(Buffer);
      end
    else
    begin
      case GetMode of
        gmNext:
          if FFilterCurRec >= RecordCount - 1 then
            Result := grEOF else
            Inc(FFilterCurRec);
        gmPrior:
          if FFilterCurRec <= 0 then
            Result := grBOF else
            Dec(FFilterCurRec);
        gmCurrent:
          if (FFilterCurRec < 0) or (FFilterCurRec >= RecordCount) then
            Result := grError;
        else GetCalcFields(Buffer);
      end;
      if (Result = grOK) then
        FCurRec := Integer(TValueBuffer(FFilterList[FFilterCurRec])) - 1
      else FCurRec := -1;
    end;

    if Result = grOK then
    begin
      FData.GetBuffer(Buffer, FCurRec);
      with PdxRecInfo(Buffer + FRecInfoOfs)^ do
      begin
        BookmarkFlag := bfCurrent;
        Bookmark := Integer(FBookMarks[FCurRec])
      end;
      GetMemBlobData(Buffer);
    end else
      if (Result = grError) and DoCheck then DatabaseError('No Records');
  end;
end;

procedure TdxMemData.InternalInitRecord(Buffer: TRecordBuffer);
begin
  FillZeroData(Buffer, FRecInfoOfs);
  FinalizeBlobData(TRecordBuffer(Integer(Buffer) + FRecBufSize));
  InitializeBlobData(TRecordBuffer(Integer(Buffer) + FRecBufSize));
end;

function TdxMemData.GetActiveRecBuf(var RecBuf: TRecordBuffer): Boolean;
begin
  case State of
    dsBrowse: if IsEmpty then RecBuf := nil else RecBuf := ActiveBuffer;
    dsEdit, dsInsert: RecBuf := ActiveBuffer;
    dsCalcFields: RecBuf := CalcBuffer;
  else
    RecBuf := nil;
  end;
  Result := RecBuf <> nil;
end;

function TdxMemData.GetFieldData(Field: TField; Buffer: TValueBuffer): Boolean;
var
  RecBuf: TRecordBuffer;
{$IFNDEF DELPHI10}
  AData: Pointer;
{$ENDIF}
begin
  Result := False;
  if not GetActiveRecBuf(RecBuf) then Exit;

  if Field.IsBlob then
    Result := Length(GetBlobData(RecBuf, Field)) > 0
  else
  {$IFNDEF DELPHI10}
    if Field.DataType = ftWideString then
    begin
      AData := AllocMem(GetDataSize(Field));
      try
        Result := FData.GetActiveBuffer(RecBuf, AData, Field);
        if (Buffer <> nil) and Result then
          PWideString(Buffer)^ := WideString(PWideChar(AData));
      finally
        FreeMem(AData);
      end;
    end
    else
  {$ENDIF}
      Result := FData.GetActiveBuffer(RecBuf, Buffer, Field);
end;

function TdxMemData.GetFieldData(Field: TField; Buffer: TValueBuffer; NativeFormat: Boolean): Boolean;
begin
  if (Field.DataType = ftWideString) then
    Result := GetFieldData(Field, Buffer)
  else Result :=  inherited GetFieldData(Field, Buffer, NativeFormat)
end;

procedure TdxMemData.SetFieldData(Field: TField; Buffer: TValueBuffer);
var
  RecBuf : TRecordBuffer;
begin
  if not (State in dsWriteModes) then
    DatabaseError(SNotEditing, Self);
  if not GetActiveRecBuf(RecBuf) then Exit;

  Field.Validate(Buffer);

  FData.SetActiveBuffer(RecBuf, Buffer, Field);

  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
    DataEvent(deFieldChange, Longint(Field));
end;

procedure TdxMemData.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean);
begin
  if (Field.DataType = ftWideString) then
    SetFieldData(Field, Buffer)
  else
    inherited SetFieldData(Field, Buffer, NativeFormat)
end;

function TdxMemData.GetStateFieldValue(State: TDataSetState