virtualdataset.pas

delphi通过OCI访问ORACLE

                if PBookmInfo(ActiveBuffer).BookmarkFlag<>bfEOF then
                 begin
                   if FCurrent=-1 then
                   begin
                     Inc(FCurrent);
                     InternalAddRecord(ActiveBuffer,False);
                     Dec(FCurrent);
                   end else
                     InternalAddRecord(ActiveBuffer,False)
                 end else
                    InternalAddRecord(ActiveBuffer,True);
               end;
  end;
end;

procedure TVirtualDataSet.InternalDelete;
var ua:TUpdateAction;
begin
  ua:=VDeleteRecord(FCurrent);
  if ua=uaAbort then abort;
  if ua<>uaApplied then raise EDatabaseError.Create('Error delete');
  InternalInitRecord(ActiveBuffer);
  Dec(FCount);
end;

function  TVirtualDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
var
  i       :integer;
  accept  :boolean;
  inv     :boolean;
//  SaveState:TDataSetState;
begin
//inv:=inherited Active;
  Result:=grOk;
  if GetMode=gmNext then
    repeat
      FCurrent:=FCurrent+1;
      VGoto(FCurrent);
      if FCurrent>=RecordCount then break;
      accept:=FCurrent<>-1;
        if Filtered and Assigned(FFilterRecordEvent) then
          FFilterRecordEvent(self,FCurrent,accept);
    until accept;

  if GetMode=gmPrior then
    repeat
      FCurrent:=FCurrent-1;
      VGoto(FCurrent);
      if FCurrent<0 then break; {roma}
      accept:=FCurrent<>-1;
        if Filtered and Assigned(FFilterRecordEvent) then
          FFilterRecordEvent(self,FCurrent,accept);

    until accept;           

  if GetMode=gmCurrent then
  begin
      VGoto(FCurrent);
      accept:=(FCurrent>=0) and (FCurrent<RecordCount);
        if Filtered and Assigned(FFilterRecordEvent) and (accept) then
          FFilterRecordEvent(self,FCurrent,accept);
      if not accept then Result:=grEOF;
  end;

  if FCurrent>=RecordCount then begin Result:=grEOF; FCurrent:=RecordCount; end;
  if FCurrent<0       then begin Result:=grBOF; FCurrent:=-1; end;

  if Result=grOk then
//  if FCurrent<RecordCount then
  begin
    if Assigned(OnFastCalcFields) then OnFastCalcFields(self,FCurrent);
    for i:=0 to FieldDefs.Count-1 do
    begin
      inv:=VGetFieldValue(FCurrent,i,
                     pointer(cardinal(Buffer) + cardinal(FFieldsOffset.Value[i])+1)
                    );
      Boolean(pointer(cardinal(Buffer) + cardinal(FFieldsOffset.Value[i]))^):=inv; // True - if data exists. False - if field=NULL
    end;
    FBookm.Get(FCurrent,@(PBookmInfo(Buffer)^.Bookmark));
    PBookmInfo(Buffer)^.BookmarkFlag:=bfCurrent;
    FCalcBuf:=Buffer;
    CalculateFields(Buffer);
    FCalcBuf:=nil;
  end;
end;

function  TVirtualDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
var
  i   :integer;
  pi:pointer;
begin
//  if FDoCalc and Assigned(OnCalculateFields) then
  Result:=False;
  if IsEmpty and (FCurrent=-1) then exit;  // needed !!! Otherwise in empty table data will be shown in first row
  i:=GetFieldID(Field.FieldName);
  if i>=FFieldsOffset.Count then exit;

  if State=dsOldValue
   then pi:=OldBuffer
   else if Assigned(FCalcBuf)
         then pi:=FCalcBuf
         else pi:=ActiveBuffer;



  pi:=pointer(cardinal(pi)+cardinal(FFieldsOffset.Value[i]));
{  if Assigned(FCalcBuf)
   then pi:=pointer(cardinal(FCalcBuf)+ofs)
   else pi:=pointer(cardinal(CalcBuffer)+ofs);}


  Result:=Boolean(pi^);
  if not Result then exit;
  if Buffer=nil then exit;

  pi:=pointer(cardinal(pi)+1);
  memcpy(pi,Buffer,FFieldsSize.Value[i]);
  if Field.DataType=ftString
   then pchar(cardinal(Buffer)+cardinal(FFieldsSize.Value[i]))^:=#0;
end;

procedure TVirtualDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  i   :integer;
  ofs :cardinal;
  po:pointer;
begin
 // if not (State in dsWriteModes) then ADatabaseError(SNotEditing, Self);
  Field.Validate(Buffer);
  i:=GetFieldID(Field.FieldName);
  ofs:=cardinal(FFieldsOffset.Value[i]);

  if Assigned(FCalcBuf)
   then po:=pointer(cardinal(FCalcBuf)+ofs)
   else po:=pointer(cardinal(ActiveBuffer)+ofs);
{  if Assigned(FCalcBuf)
   then po:=pointer(cardinal(FCalcBuf)+ofs)
   else po:=pointer(cardinal(CalcBuffer)+ofs);}

  if Buffer=nil then
  begin
    FillChar(po^,Integer(FFieldsSize.Value[i])+1,0);
    if not (State in [dsBrowse, dsCalcFields, dsFilter, dsNewValue]) then
      DataEvent(deFieldChange, Longint(Field));
    exit;
  end;
  Boolean(po^):=True;
  po:=pointer(cardinal(po)+1);
  memcpy(Buffer,po,FFieldsSize.Value[i]);
  if not (State in [dsBrowse, dsCalcFields, dsFilter, dsNewValue]) then
    DataEvent(deFieldChange, Longint(Field));
end;

procedure TVirtualDataSet.InternalFirst;
var
  accept : boolean;
begin
  FCurrent:=-1;

  //exit;
/////////////////////////////////////////////////
  repeat
    FCurrent:=FCurrent+1;
    if FCurrent>=RecordCount then begin break;end;
    accept:=true;
    try
      if Filtered and Assigned(FFilterRecordEvent) then
        FFilterRecordEvent(self,FCurrent,accept);
    except
      on Exception do accept:=false;
    end;

  until accept;
//  if FCurrent=0 then FCurrent:=-1;
  dec(FCurrent);{roma}
end;

procedure TVirtualDataSet.InternalLast;
var
  accept : boolean;
begin
  VReadAll;
  FCurrent:=RecordCount;

// exit;
//////////////////////////
  repeat
    FCurrent:=FCurrent-1;
    if FCurrent<0 then break;
    accept:=true;
    try
      if Filtered and Assigned(FFilterRecordEvent) then
        FFilterRecordEvent(self,FCurrent,accept);
    except
      on Exception do accept:=false;
    end;
  until accept;
  //if FCurrent=(RecordCount-1) then FCurrent:=RecordCount;
  inc(FCurrent);
end;

procedure TVirtualDataSet.InternalHandleException;
begin
 raise Exception.Create('TVirtualDataSet.InternalHandleException'); {roma 14.12.2000}
end;

procedure TVirtualDataSet.ClearDataSet;
begin
end;

procedure TVirtualDataSet.SetFiltered(Value:boolean);
begin
 inherited SetFiltered(Value);
 if FOpened then Resync([]);// Refresh; {roma 13.08.2000}
end;

function TVirtualDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
                    Options: TLocateOptions): Boolean;
var
  FieldList:THArrayInteger;
  sl1,sl2:TStrings;
  p,i:integer;
  Accept:boolean;
  Bookm : integer;

  function AnsiCompareCS(const v,w: string; CaseSensitive: boolean; PartialKey: boolean): boolean;
  var s: string;
  begin
   if PartialKey
    then s := Copy(w, 1, length(v))
    else s := w;
   if CaseSensitive
    then Result := AnsiCompareStr(v,s)=0
    else Result := AnsiCompareText(v,s)=0
  end;

  function Compare: boolean;
  var i: integer;
  begin
   Result:=True;
   for i:=0 to sl1.Count-1 do
    if not AnsiCompareCS(sl1[i],sl2[i],not(loCaseInsensitive in Options),loPartialKey in Options) then begin
     Result:=False;
     exit;
    end;
  end;

  procedure FillCurKeyValues;
  var i:integer;
  begin
   sl2.Clear;
   for i:=0 to FieldList.Count-1 do sl2.Add(VarToStr(GetFieldValue(p,FieldList[i])))
  end;

  function VGetFieldList(FieldList:THArrayInteger;const FieldNames:string):boolean;
  var Pos,f:integer;
  begin
   Result:=True;
   Pos:=1;
   while Pos<=Length(FieldNames) do begin
    Result:=True;
    try
     f:=GetFieldID(ExtractFieldName(FieldNames,Pos));
     FieldList.AddValue(f);
    except
     Result:=False;
    end;
   end;
  end;

begin
 Result:=False;
 FieldList:=THArrayInteger.Create;
 sl1:=TStringList.Create;
 sl2:=TStringList.Create;
 try
  if not VGetFieldList(FieldList,KeyFields) then exit;
  if FieldList.Count=1
   then sl1.Add(VarToStr(KeyValues))
   else for i:=0 to FieldList.Count-1 do
          sl1.Add(VarToStr(KeyValues[i]));

  p:=0;

//  VReadAll;
 repeat
  while p<RecordCount do begin
   Accept:=True;
   if Filtered and Assigned(FFilterRecordEvent)
    then FFilterRecordEvent(self,p,Accept);
   if Accept then begin
    FillCurKeyValues;
    Result:=Compare;
    if Result then begin
     Bookm:=FBookm.Value[p];
     GotoBookmark(@Bookm);
     exit;
    end;
   end;
   inc(p);
  end;
 until not FetchNextBlock;
 finally
  sl2.Free;
  sl1.Free;
  FieldList.Free;
 end;
end;

function TVirtualDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
  const ResultFields: string): Variant;
var
  FieldList:THArrayInteger;
  sl1,sl2:TStrings;
  p,i:integer;
  Accept:boolean;
  Bookm1 : TBookmark;
  Bookm2 : integer;

  function AnsiCompareCS(const v,w: string; CaseSensitive: boolean; PartialKey: boolean): boolean;
  var s: string;
  begin
   if PartialKey
    then s := Copy(w, 1, length(v))
    else s := w;
   if CaseSensitive
    then Result := AnsiCompareStr(v,s)=0
    else Result := AnsiCompareText(v,s)=0
  end;

  function Compare: boolean;
  var i: integer;
  begin
   Result:=True;
   for i:=0 to sl1.Count-1 do
    if not AnsiCompareCS(sl1[i],sl2[i],True,False) then begin
     Result:=False;
     exit;
    end;
  end;

  procedure FillCurKeyValues;
  var i:integer;
  begin
   sl2.Clear;
   for i:=0 to FieldList.Count-1 do sl2.Add(VarToStr(GetFieldValue(p,FieldList[i])))
  end;

  function VGetFieldList(FieldList:THArrayInteger;const FieldNames:string):boolean;
  var Pos,f:integer;
  begin
   Result:=True;
   Pos:=1;
   while Pos<=Length(FieldNames) do begin
    Result:=True;
    try
     f:=GetFieldID(ExtractFieldName(FieldNames,Pos));
     FieldList.AddValue(f);
    except
     Result:=False;
    end;
   end;
  end;

begin
 Result:=Null;
 FieldList:=THArrayInteger.Create;
 sl1:=TStringList.Create;
 sl2:=TStringList.Create;
 try
  if not VGetFieldList(FieldList,KeyFields) then exit;
  if FieldList.Count=1
   then sl1.Add(VarToStr(KeyValues))
   else for i:=0 to FieldList.Count-1 do
          sl1.Add(VarToStr(KeyValues[i]));

  p:=0;

//  VReadAll;
 repeat
  while p<RecordCount do begin
   Accept:=True;
   if Filtered and Assigned(FFilterRecordEvent)
    then FFilterRecordEvent(self,p,Accept);
   if Accept then begin
    FillCurKeyValues;
    if Compare then begin
     Bookm1:=GetBookmark; //remember current position
     Bookm2:=FBookm.Value[p];
     GotoBookmark(@Bookm2); // go to the found record
     Result:=FieldValues[ResultFields]; // get found data
     GotoBookmark(Bookm1); // return back to the remembered position
     exit;
    end;
   end;
   inc(p);
  end;
 until not FetchNextBlock;
 finally
  sl2.Free;
  sl1.Free;
  FieldList.Free;
 end;
end;

procedure TVirtualDataSet.ReOpen;
begin
 Close;
 Open;
end;

function TVirtualDataSet.CompareBookmarks(Bookmark1,
  Bookmark2: TBookmark): integer;
const
 RetCodes: array[Boolean, Boolean] of ShortInt = ((2,-1),(1,0));
begin
  { Check for uninitialized bookmarks }
  Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
  if Result = 2 then begin
   if PBookmInfo(Bookmark1).Bookmark<PBookmInfo(Bookmark2).Bookmark
    then Result := -1
    else if PBookmInfo(Bookmark1).Bookmark>PBookmInfo(Bookmark2).Bookmark
          then Result := 1
          else Result := 0;
  end;
end;

procedure TVirtualDataSet.VReadAll;
begin
 while FetchNextBlock do;
end;

procedure TVirtualDataSet.OpenAll;
begin
 Open;
 VReadAll;
end;

procedure TVirtualDataSet.InternalEdit;
begin
 memcpy(ActiveBuffer,OldBuffer,RecordSize);
end;

procedure TVirtualDataSet.CopyStructure(DataSet: TDataSet);
var i:integer;
begin
 FieldDefs.Clear;
 for i:=0 to DataSet.FieldDefs.Count-1 do begin
   FieldDefs.Add(DataSet.FieldDefs[i].Name,DataSet.FieldDefs[i].DataType,DataSet.FieldDefs[i].Size,DataSet.FieldDefs[i].Required);
 end;
end;

end.