home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kompon / d45 / ARDOCI.ZIP / VirtualDataSet.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2001-06-21  |  24.8 KB  |  893 lines
  1. unit VirtualDataSet;
  2.  
  3. {
  4.  ═α±δσΣ≤σ≥±  ε≥ TDataSet
  5.  
  6.  ▌≥ε wrapper φαΣ TDataSet, Σδ  Γ√∩εδφσφΦ  Γ±σ⌡ Delphi-specific ⌠≤φΩ÷ΦΘ
  7.   
  8. }
  9.  
  10.  
  11. {
  12.  ─αφφ√σ Γ ß≤⌠σ≡σ ⌡≡αφ ≥±  Γ ΓΦΣσ, ±εΓ∞σ±≥Φ∞ε∞ ± BDE:
  13.   ftInteger - ΩαΩ integer(4 ßαΘ≥α)
  14.   ftSmallInt - ΩαΩ smallint(2 ßαΘ≥α)
  15.   ftFloat   - ΩαΩ double (8 ßαΘ≥)
  16.   ftCurrency - ΩαΩ double(8 ßαΘ≥)
  17.   ftDate - ΩαΩ TDateTimeRec
  18.   ftTime - ΩαΩ TDateTimeRec
  19.   ftDateTime - ΩαΩ TDateTimeRec
  20.   ftWord - ΩαΩ Word(2 ßαΘ≥α)
  21.   ftBoolean - ΩαΩ WordBool(2 ßαΘ≥α)
  22.   ftBlob,ftMemo - φσ ⌡≡αφ ≥± 
  23.   ftString  - ΩαΩ pchar (Size ßαΘ≥), Γετ∞εµφε ßστ #0 φα ⌡Γε±≥σ
  24. }
  25.  
  26. interface
  27.  
  28. uses Db, Classes, DynamicArrays;
  29.  
  30. type
  31. {$IFDEF VER120}  { Borland Delphi 4.0 }
  32.   TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
  33.   TUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) of object;
  34. {$ENDIF}
  35.  
  36.   TVirtualDataSet = class;
  37.  
  38.   TBookmInfo = record
  39.    Bookmark     : integer;
  40.    BookmarkFlag: TBookmarkFlag;
  41.   end;
  42.   PBookmInfo=^TBookmInfo;
  43.   PInteger=^Integer;
  44.   TPutMode = (pmAppend,pmInsert,pmUpdate);
  45.   TVirtualFilterRecordEvent = procedure(DataSet: TVirtualDataSet; RecNum : integer;
  46.                                           var Accept: Boolean) of object;
  47.   TOnFastCalcFields = procedure(DataSet: TVirtualDataSet; RecNum : integer) of object;
  48.  
  49.   TVirtualDataSet = class(TDataSet)
  50.   private
  51.    FCalcBuf:pointer;
  52.    FFieldsOffset :THArrayInteger;
  53.    FFieldsSize   :THArrayInteger;
  54.    FOpened       :boolean;
  55.    FRecSize      :word;
  56.  
  57.    FFilterRecordEvent :TVirtualFilterRecordEvent;
  58.    FOnFastCalcFields :TOnFastCalcFields;
  59.    FAfterInternalOpen: TDataSetNotifyEvent;
  60.    OldBuffer:pointer;
  61.    procedure VReadAll;
  62.    
  63.   protected
  64.    FCount        :integer;
  65.    FCurrent      :integer;
  66.    FBookm        :THArrayInteger;
  67.    UniqBookmark  :integer;
  68.  
  69.    function GetRecNo : integer; override;
  70.  
  71.    //abstract methods
  72.    function  VOpen            :boolean; virtual; abstract;
  73.    function  VPrepare         :boolean; virtual; abstract;
  74.    function  VClose           :boolean; virtual; abstract;
  75.    procedure VGoto(RecordNum :integer); virtual; abstract;
  76.    procedure VInitFieldDefs(Opened:boolean); virtual; abstract;
  77.  
  78.    function  VGetFieldValue( RecordNum:integer;
  79.                              FieldID  :integer;
  80.                              Buffer   :pointer):boolean; virtual; abstract;
  81.  
  82.    procedure VPutFieldValue( RecordNum:integer;
  83.                              FieldID  :integer;
  84.                              Buffer   :pointer;
  85.                              mode     :TPutMode;
  86.                              IfNotNull:Boolean);virtual; abstract;
  87.  
  88.    function VPost        (RecordNum:integer):TUpdateAction;  virtual; abstract;
  89.    function VInsert      (RecordNum:integer):TUpdateAction;  virtual; abstract;
  90.    function VDeleteRecord(RecordNum:integer):TUpdateAction;  virtual; abstract;
  91.  
  92.    function FetchNextBlock:boolean; virtual; abstract;
  93.  
  94.    function GetRealSize(FieldType:TFieldType;Size:integer):integer;
  95.  
  96.    //overrided methods from TDataSet
  97.    procedure InternalOpen;                                  override;
  98.    procedure InternalEdit;                                  override;
  99.    procedure InternalInitFieldDefs;                         override;
  100.    procedure InternalClose;                                 override;
  101.    procedure InternalInsert;                                override;
  102.    function  IsCursorOpen:boolean;                          override;
  103.    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
  104.    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
  105.    function  GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
  106.    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
  107.    procedure InternalSetToRecord(Buffer: PChar);            override;
  108.    procedure InternalGotoBookmark(Bookmark: Pointer);       override;
  109.    function  GetRecordCount:integer;        override;
  110.    function  AllocRecordBuffer:PChar;       override;
  111.    procedure FreeRecordBuffer(var Buffer: PChar);           override;
  112.    function  GetRecordSize: Word;                           override;
  113.    procedure InternalInitRecord(Buffer: PChar);             override;
  114.    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
  115.    procedure InternalPost; override;
  116.    procedure InternalDelete; override;
  117.    function  GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
  118.    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
  119.    procedure InternalFirst; override;
  120.    procedure InternalLast; override;
  121.    procedure InternalHandleException; override;
  122.    procedure SetFiltered(Value:boolean); override;
  123.  
  124.    procedure SetRecNo(Value : integer); override;
  125.    function  GetFieldID(FieldName : string) : integer;
  126.    function  GetFieldCount: integer;
  127.  
  128.    procedure ClearDataSet; virtual;
  129.   public
  130.     constructor Create(AOwner:TComponent);override;
  131.     destructor  Destroy; override;
  132.     procedure SetFieldValue(RecordNum:integer; FieldID : integer; Value:variant); virtual; abstract;
  133.     function GetFieldValue(RecordNum:integer; FieldID : integer):variant; virtual; abstract;
  134.     procedure GotoRecNum(RecNum:integer);
  135.     function  GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  136.     procedure OpenAll;
  137.  
  138.     procedure ReOpen;
  139.  
  140.     property  RecNo; //for internal use
  141.     procedure CopyStructure(DataSet:TDataSet);
  142.  
  143.     function Locate(const KeyFields: string; const KeyValues: Variant;
  144.                     Options: TLocateOptions): Boolean; override;
  145.     function Lookup(const KeyFields: string; const KeyValues: Variant;
  146.                     const ResultFields: string): Variant;override;
  147.  
  148.     property FieldID[Index:string]:integer read GetFieldID;
  149.  
  150.     property ActiveRecord;
  151.     property CurrentRecord;
  152.  
  153.    function CompareBookmarks(Bookmark1,Bookmark2:TBookmark):integer;override;
  154.  
  155.   published
  156.    property Active;
  157.    property BeforeOpen;
  158.    property AfterOpen;
  159.    property BeforeClose;
  160.    property AfterClose;
  161.    property BeforeInsert;
  162.    property AfterInsert;
  163.    property BeforeEdit;
  164.    property AfterEdit;
  165.    property BeforePost;
  166.    property AfterPost;
  167.    property BeforeCancel;
  168.    property AfterCancel;
  169.    property BeforeDelete;
  170.    property AfterDelete;
  171.    property BeforeScroll;
  172.    property AfterScroll;
  173.    property OnFastCalcFields:TOnFastCalcFields read FOnFastCalcFields write FOnFastCalcFields;
  174.    property OnDeleteError;
  175.    property OnEditError;
  176.    property OnNewRecord;
  177.    property OnPostError;
  178.    property Filtered;
  179.    property AfterInternalOpen: TDataSetNotifyEvent read FAfterInternalOpen write FAfterInternalOpen;
  180.    property OnVFilterRecord : TVirtualFilterRecordEvent
  181.                          read  FFilterRecordEvent
  182.                          write FFilterRecordEvent;
  183.  
  184.   end;
  185.  
  186. implementation
  187.  
  188. uses SysUtils, DBConsts;
  189.  
  190. constructor TVirtualDataSet.Create(AOwner:TComponent);
  191. begin
  192.   inherited Create(Aowner);
  193.   FFieldsOffset:=THArrayInteger.Create;
  194.   FFieldsSize:=THArrayInteger.Create;
  195.   FBookm:=THArrayInteger.Create;
  196.   UniqBookmark:=0;
  197.   FCount:=0;
  198.   FCurrent:=-1;
  199.   FOpened:=False;
  200.   FCalcBuf:=nil;
  201. end;
  202.  
  203. destructor TVirtualDataSet.Destroy;
  204. begin
  205.   FFieldsOffset.Free;
  206.   FFieldsSize.Free;
  207.   FBookm.Free;
  208.   inherited Destroy;
  209. end;
  210.  
  211. procedure TVirtualDataSet.InternalOpen;
  212. var
  213.   i         :integer;
  214.   RealSize  :integer;
  215.   off       :word;
  216. begin
  217.   ClearBuffers;
  218.   BookmarkSize:=sizeof(TBookmInfo);
  219.   FCount:=0;
  220.   FCurrent:=-1;
  221.   if DefaultFields then begin
  222.    VInitFieldDefs(True);
  223.    CreateFields;
  224.   end;
  225.   FOpened:=VOpen;
  226.   if not FOpened then exit;
  227.  
  228.   FFieldsOffset.ClearMem;
  229.   FFieldsSize.ClearMem;
  230.   FBookm.ClearMem;
  231.   UniqBookmark:=0;
  232.  
  233.   off:=sizeof(TBookmInfo);
  234.   for i:=0 to FieldDefs.Count-1 do begin
  235.     FFieldsOffset.AddValue(off);
  236.     RealSize:=GetRealSize(FieldDefs[i].DataType,FieldDefs[i].Size);
  237.     FFieldsSize.AddValue(RealSize);
  238.     off:=off+RealSize+1;  //one extra byte for isFieldNull function
  239.   end;
  240.   FRecSize:=off;
  241.  
  242.   BindFields(True);
  243.   OldBuffer:=AllocMem(RecordSize);
  244.   if Assigned (AfterInternalOpen) then AfterInternalOpen(self);
  245. end;
  246.  
  247. function TVirtualDataSet.GetRealSize(FieldType:TFieldType;Size:integer):integer;
  248. begin
  249.   case FieldType of
  250.        ftFloat           : Result:=SizeOf(Double);
  251.        ftCurrency        : Result:=SizeOf(Currency);
  252.        ftInteger         : Result:=SizeOf(Integer);
  253.        ftSmallInt        : Result:=SizeOf(SmallInt);
  254.        ftDate            : Result:=SizeOf(TDateTimeRec);
  255.        ftTime            : Result:=SizeOf(TDateTimeRec);
  256.        ftWord            : Result:=SizeOf(Word);
  257.        ftBoolean         : Result:=SizeOf(WordBool);
  258.        ftDateTime        : Result:=SizeOf(TDateTimeRec);
  259.        ftString          : Result:=Size;
  260.        ftBlob,ftMemo     : Result:=2*SizeOf(pointer); // BlobSize and pointer to memory where BLOB field stores data
  261.     else
  262.        Result:=Size;
  263.   end;
  264. end;
  265.  
  266. function  TVirtualDataSet.GetFieldID(FieldName : string) : integer;
  267. begin
  268.   Result:=FieldDefs.IndexOf(FieldName);
  269.   if Result=-1 then raise Exception.Create('Field "'+FieldName+'" not found!');
  270. end;
  271.  
  272. function  TVirtualDataSet.GetFieldCount : integer;
  273. begin
  274.   Result:=FieldDefs.Count;
  275. end;
  276.  
  277. procedure TVirtualDataSet.InternalClose;
  278. begin
  279.   if not FOpened then exit;
  280.   if DefaultFields then Fields.Clear;
  281.   FOpened:=not VClose;
  282.   FCount:=0;
  283.   FBookm.ClearMem;
  284.   FFieldsOffset.ClearMem;
  285.   FFieldsSize.ClearMem;
  286.   FreeMem(OldBuffer);
  287.   OldBuffer:=nil;
  288. end;
  289.  
  290. procedure TVirtualDataSet.InternalInitFieldDefs;
  291. begin
  292.  if Active then exit;
  293.  VInitFieldDefs(False);
  294. end;
  295.  
  296. function TVirtualDataSet.IsCursorOpen:boolean;
  297. begin
  298.   Result:=FOpened;
  299. end;
  300.  
  301. procedure TVirtualDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
  302. begin
  303.   PInteger(Data)^:=PBookmInfo(Buffer).Bookmark;
  304. end;
  305.  
  306. procedure TVirtualDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
  307. begin
  308.   PBookmInfo(Buffer).Bookmark:=PInteger(Data)^;
  309. end;
  310.  
  311. function  TVirtualDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
  312. begin
  313.   Result:=PBookmInfo(Buffer).BookmarkFlag;
  314. end;
  315.  
  316. procedure TVirtualDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
  317. begin
  318.   PBookmInfo(Buffer).BookmarkFlag:=Value;
  319. end;
  320.  
  321. procedure TVirtualDataSet.InternalSetToRecord(Buffer: PChar);
  322. begin
  323.   FCurrent:=FBookm.IndexOf(PBookmInfo(Buffer).Bookmark);
  324.   //MoveBy(1);
  325.   //PBookmInfo(Buffer).BookmarkFlag := bfCurrent;
  326. {  if PBookmInfo(Buffer).BookmarkFlag=bfBOF then
  327.     FCurrent:=FCurrent-1;}
  328. end;
  329.  
  330. procedure TVirtualDataSet.GotoRecNum(RecNum:integer);
  331. var u:integer;
  332. begin
  333. // b.Bookmark
  334.   u:=FBookm[RecNum];
  335.   GotoBookmark(@u);
  336. end;
  337.  
  338. procedure TVirtualDataSet.InternalGotoBookmark(Bookmark: Pointer);
  339. begin
  340.   InternalSetToRecord(PChar(bookmark));
  341. end;
  342.  
  343. function  TVirtualDataSet.GetRecordCount:integer;
  344. begin
  345.  Result:=FCount;
  346. end;
  347.  
  348. function  TVirtualDataSet.AllocRecordBuffer:PChar;
  349. begin
  350.   Result:=AllocMem(FRecSize);
  351. end;
  352.  
  353. procedure TVirtualDataSet.FreeRecordBuffer(var Buffer: PChar);
  354. begin
  355.   FreeMem(Buffer);
  356. end;
  357.  
  358. function  TVirtualDataSet.GetRecordSize: Word;
  359. begin
  360.   Result:=FRecSize;
  361. end;
  362.  
  363. function TVirtualDataSet.GetRecNo : integer;
  364. begin
  365.   UpdateCursorPos;
  366.   Result:=FCurrent;
  367. end;
  368.  
  369. procedure TVirtualDataSet.SetRecNo(Value : integer);
  370. begin
  371.  if (Value>-1) and (Value<RecordCount) then
  372.  begin
  373.    FCurrent:=Value;
  374.    Resync([]);//Refresh; {roma 13.08.2000}
  375.  end;
  376. end;
  377.  
  378. procedure TVirtualDataSet.InternalInitRecord(Buffer: PChar);
  379. begin
  380.   FillChar(Buffer^,RecordSize,#0);
  381. end;
  382.  
  383. procedure TVirtualDataSet.InternalInsert;
  384. begin
  385.  // ∩εΩα φΦ≈σπε
  386. end;
  387.  
  388. procedure TVirtualDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
  389. var
  390.   i    : integer;
  391.   mode : TPutMode;
  392.   r:integer;
  393. begin
  394.   r:=FCurrent;
  395.   if r=-1 then r:=0;
  396.   if Append then r:=RecordCount;
  397.  
  398.   if Append
  399.    then mode:=pmAppend
  400.    else mode:=pmInsert;
  401.  
  402.   VInsert(r);
  403.   for i:=0 to FieldDefs.Count-1 do
  404.     VPutFieldValue(r,i,
  405.                    pointer(cardinal(Buffer) +
  406.                            cardinal(FFieldsOffset.Value[i])+1),
  407.                    mode, Boolean(pointer(cardinal(Buffer)+cardinal(FFieldsOffset.Value[i]))^));
  408. //  Inc(UniqBookmark); // VInsert automatically call FBookm.Insert
  409. //  FBookm.AddValue(UniqBookmark);
  410.   if mode=pmAppend then FCurrent:=RecordCount;
  411.   Inc(FCount);
  412. end;
  413.  
  414. procedure TVirtualDataSet.InternalPost;
  415. var
  416.   i    : integer;
  417.   mode : TPutMode;
  418.   ua : TUpdateAction;
  419. begin
  420.   case State of
  421.     dsEdit   : begin
  422.                  ua:=VPost(FCurrent);
  423.                  if ua<>uaApplied then abort;
  424.                  if ua=uaAbort then abort;
  425.                  mode:=pmUpdate;
  426.                  for i:=0 to FieldDefs.Count-1 do
  427.                    VPutFieldValue(FCurrent,i,
  428.                                   pointer(cardinal(ActiveBuffer) +
  429.                                           cardinal(FFieldsOffset.Value[i])+1),
  430.                                   mode,
  431.                                   Boolean(pointer(cardinal(ActiveBuffer) +
  432.                                           cardinal(FFieldsOffset.Value[i]))^));
  433.  
  434.                end;
  435.     dsInsert : begin
  436.                 if FCurrent<>-1 then ua:=VPost(FCurrent) else ua:=VPost(0);
  437.                 if ua=uaAbort then abort;
  438.                 if ua<>uaApplied then abort;
  439.                 if PBookmInfo(ActiveBuffer).BookmarkFlag<>bfEOF then
  440.                  begin
  441.                    if FCurrent=-1 then
  442.                    begin
  443.                      Inc(FCurrent);
  444.                      InternalAddRecord(ActiveBuffer,False);
  445.                      Dec(FCurrent);
  446.                    end else
  447.                      InternalAddRecord(ActiveBuffer,False)
  448.                  end else
  449.                     InternalAddRecord(ActiveBuffer,True);
  450.                end;
  451.   end;
  452. end;
  453.  
  454. procedure TVirtualDataSet.InternalDelete;
  455. var ua:TUpdateAction;
  456. begin
  457.   ua:=VDeleteRecord(FCurrent);
  458.   if ua=uaAbort then abort;
  459.   if ua<>uaApplied then raise Exception.Create('Error delete');
  460.   InternalInitRecord(ActiveBuffer);
  461.   Dec(FCount);
  462. end;
  463.  
  464. function  TVirtualDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
  465. var
  466.   i       :integer;
  467.   accept  :boolean;
  468.   inv     :boolean;
  469. //  SaveState:TDataSetState;
  470. begin
  471. //inv:=inherited Active;
  472.   Result:=grOk;
  473.   if GetMode=gmNext then
  474.     repeat
  475.       FCurrent:=FCurrent+1;
  476.       VGoto(FCurrent);
  477.       if FCurrent>=RecordCount then break;
  478.       accept:=FCurrent<>-1;
  479.         if Filtered and Assigned(FFilterRecordEvent) then
  480.           FFilterRecordEvent(self,FCurrent,accept);
  481.     until accept;
  482.  
  483.   if GetMode=gmPrior then
  484.     repeat
  485.       FCurrent:=FCurrent-1;
  486.       VGoto(FCurrent);
  487.       if FCurrent<0 then break; {roma}
  488.       accept:=FCurrent<>-1;
  489.         if Filtered and Assigned(FFilterRecordEvent) then
  490.           FFilterRecordEvent(self,FCurrent,accept);
  491.  
  492.     until accept;           
  493.  
  494.   if GetMode=gmCurrent then
  495.   begin
  496.       VGoto(FCurrent);
  497.       accept:=(FCurrent>=0) and (FCurrent<RecordCount);
  498.         if Filtered and Assigned(FFilterRecordEvent) and (accept) then
  499.           FFilterRecordEvent(self,FCurrent,accept);
  500.       if not accept then Result:=grEOF;
  501.   end;
  502.  
  503.   if FCurrent>=RecordCount then begin Result:=grEOF; FCurrent:=RecordCount; end;
  504.   if FCurrent<0       then begin Result:=grBOF; FCurrent:=-1; end;
  505.  
  506.   if Result=grOk then
  507. //  if FCurrent<RecordCount then
  508.   begin
  509.     if Assigned(OnFastCalcFields) then OnFastCalcFields(self,FCurrent);
  510.     for i:=0 to FieldDefs.Count-1 do
  511.     begin
  512.       inv:=VGetFieldValue(FCurrent,i,
  513.                      pointer(cardinal(Buffer) + cardinal(FFieldsOffset.Value[i])+1)
  514.                     );
  515.       Boolean(pointer(cardinal(Buffer) + cardinal(FFieldsOffset.Value[i]))^):=inv; // True - σ±δΦ Σαφφ√σ σ±≥ⁿ. False - σ±δΦ ∩εδσ=NULL
  516.     end;
  517.     FBookm.Get(FCurrent,@(PBookmInfo(Buffer)^.Bookmark));
  518.     PBookmInfo(Buffer)^.BookmarkFlag:=bfCurrent;
  519.     FCalcBuf:=Buffer;
  520.     CalculateFields(Buffer);
  521.     FCalcBuf:=nil;
  522.   end;
  523. end;
  524.  
  525. function  TVirtualDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
  526. var
  527.   i   :integer;
  528.   pi:pointer;
  529. begin
  530. //  if FDoCalc and Assigned(OnCalculateFields) then
  531.   Result:=False;
  532.   if IsEmpty and (FCurrent=-1) then exit;  // εß τα≥σδⁿφε !!! ╚φα≈σ Γ ∩≤±≥εΘ ≥αßδΦ÷σ ∩εΩατ√Γα■≥±  Σαφφ√σ Γ ∩σ≡ΓεΘ ±≥≡εΩσ
  533.   i:=GetFieldID(Field.FieldName);
  534.   if i>=FFieldsOffset.Count then exit;
  535.  
  536.   if State=dsOldValue
  537.    then pi:=OldBuffer
  538.    else if Assigned(FCalcBuf)
  539.          then pi:=FCalcBuf
  540.          else pi:=ActiveBuffer;
  541.  
  542.  
  543.  
  544.   pi:=pointer(cardinal(pi)+cardinal(FFieldsOffset.Value[i]));
  545. {  if Assigned(FCalcBuf)
  546.    then pi:=pointer(cardinal(FCalcBuf)+ofs)
  547.    else pi:=pointer(cardinal(CalcBuffer)+ofs);}
  548.  
  549.  
  550.   Result:=Boolean(pi^);
  551.   if not Result then exit;
  552.   if Buffer=nil then exit;
  553.  
  554.   pi:=pointer(cardinal(pi)+1);
  555.   memcpy(pi,Buffer,FFieldsSize.Value[i]);
  556.   if Field.DataType=ftString
  557.    then pchar(cardinal(Buffer)+cardinal(FFieldsSize.Value[i]))^:=#0;
  558. end;
  559.  
  560. procedure TVirtualDataSet.SetFieldData(Field: TField; Buffer: Pointer);
  561. var
  562.   i   :integer;
  563.   ofs :cardinal;
  564.   po:pointer;
  565. begin
  566.  // if not (State in dsWriteModes) then DatabaseError(SNotEditing, Self);
  567.   Field.Validate(Buffer);
  568.   i:=GetFieldID(Field.FieldName);
  569.   ofs:=cardinal(FFieldsOffset.Value[i]);
  570.  
  571.   if Assigned(FCalcBuf)
  572.    then po:=pointer(cardinal(FCalcBuf)+ofs)
  573.    else po:=pointer(cardinal(ActiveBuffer)+ofs);
  574. {  if Assigned(FCalcBuf)
  575.    then po:=pointer(cardinal(FCalcBuf)+ofs)
  576.    else po:=pointer(cardinal(CalcBuffer)+ofs);}
  577.  
  578.   if Buffer=nil then
  579.   begin
  580.     FillChar(po^,Integer(FFieldsSize.Value[i])+1,0);
  581.     if not (State in [dsBrowse, dsCalcFields, dsFilter, dsNewValue]) then
  582.       DataEvent(deFieldChange, Longint(Field));
  583.     exit;
  584.   end;
  585.   Boolean(po^):=True;
  586.   po:=pointer(cardinal(po)+1);
  587.   memcpy(Buffer,po,FFieldsSize.Value[i]);
  588.   if not (State in [dsBrowse, dsCalcFields, dsFilter, dsNewValue]) then
  589.     DataEvent(deFieldChange, Longint(Field));
  590. end;
  591.  
  592. procedure TVirtualDataSet.InternalFirst;
  593. var
  594.   accept : boolean;
  595. begin
  596.   FCurrent:=-1;
  597.  
  598.   //exit;
  599. /////////////////////////////////////////////////
  600.   repeat
  601.     FCurrent:=FCurrent+1;
  602.     if FCurrent>=RecordCount then begin break;end;
  603.     accept:=true;
  604.     try
  605.       if Filtered and Assigned(FFilterRecordEvent) then
  606.         FFilterRecordEvent(self,FCurrent,accept);
  607.     except
  608.       on Exception do accept:=false;
  609.     end;
  610.  
  611.   until accept;
  612. //  if FCurrent=0 then FCurrent:=-1;
  613.   dec(FCurrent);{roma}
  614. end;
  615.  
  616. procedure TVirtualDataSet.InternalLast;
  617. var
  618.   accept : boolean;
  619. begin
  620.   VReadAll;
  621.   FCurrent:=RecordCount;
  622.  
  623. // exit;
  624. //////////////////////////
  625.   repeat
  626.     FCurrent:=FCurrent-1;
  627.     if FCurrent<0 then break;
  628.     accept:=true;
  629.     try
  630.       if Filtered and Assigned(FFilterRecordEvent) then
  631.         FFilterRecordEvent(self,FCurrent,accept);
  632.     except
  633.       on Exception do accept:=false;
  634.     end;
  635.   until accept;
  636.   //if FCurrent=(RecordCount-1) then FCurrent:=RecordCount;
  637.   inc(FCurrent);
  638. end;
  639.  
  640. procedure TVirtualDataSet.InternalHandleException;
  641. begin
  642.  // MessageDlg('20',mtWarning,[mbOk],0);
  643.  raise Exception.Create('20'); {roma 14.12.2000}
  644. end;
  645.  
  646. procedure TVirtualDataSet.ClearDataSet;
  647. begin
  648. end;
  649.  
  650. procedure TVirtualDataSet.SetFiltered(Value:boolean);
  651. begin
  652.  inherited SetFiltered(Value);
  653.  if FOpened then Resync([]);// Refresh; {roma 13.08.2000}
  654. end;
  655.  
  656. function TVirtualDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
  657.                     Options: TLocateOptions): Boolean;
  658. var
  659.   FieldList:THArrayInteger;
  660.   sl1,sl2:TStrings;
  661.   p,i:integer;
  662.   Accept:boolean;
  663.   Bookm : integer;
  664.  
  665.   function AnsiCompareCS(const v,w: string; CaseSensitive: boolean; PartialKey: boolean): boolean;
  666.   var s: string;
  667.   begin
  668.    if PartialKey
  669.     then s := Copy(w, 1, length(v))
  670.     else s := w;
  671.    if CaseSensitive
  672.     then Result := AnsiCompareStr(v,s)=0
  673.     else Result := AnsiCompareText(v,s)=0
  674.   end;
  675.  
  676.   function Compare: boolean;
  677.   var i: integer;
  678.   begin
  679.    Result:=True;
  680.    for i:=0 to sl1.Count-1 do
  681.     if not AnsiCompareCS(sl1[i],sl2[i],not(loCaseInsensitive in Options),loPartialKey in Options) then begin
  682.      Result:=False;
  683.      exit;
  684.     end;
  685.   end;
  686.  
  687.   procedure FillCurKeyValues;
  688.   var i:integer;
  689.   begin
  690.    sl2.Clear;
  691.    for i:=0 to FieldList.Count-1 do sl2.Add(VarToStr(GetFieldValue(p,FieldList[i])))
  692.   end;
  693.  
  694.   function VGetFieldList(FieldList:THArrayInteger;const FieldNames:string):boolean;
  695.   var Pos,f:integer;
  696.   begin
  697.    Result:=True;
  698.    Pos:=1;
  699.    while Pos<=Length(FieldNames) do begin
  700.     Result:=True;
  701.     try
  702.      f:=GetFieldID(ExtractFieldName(FieldNames,Pos));
  703.      FieldList.AddValue(f);
  704.     except
  705.      Result:=False;
  706.     end;
  707.    end;
  708.   end;
  709.  
  710. begin
  711.  Result:=False;
  712.  FieldList:=THArrayInteger.Create;
  713.  sl1:=TStringList.Create;
  714.  sl2:=TStringList.Create;
  715.  try
  716.   if not VGetFieldList(FieldList,KeyFields) then exit;
  717.   if FieldList.Count=1
  718.    then sl1.Add(VarToStr(KeyValues))
  719.    else for i:=0 to FieldList.Count-1 do
  720.           sl1.Add(VarToStr(KeyValues[i]));
  721.  
  722.   p:=0;
  723.  
  724. //  VReadAll;
  725.  repeat
  726.   while p<RecordCount do begin
  727.    Accept:=True;
  728.    if Filtered and Assigned(FFilterRecordEvent)
  729.     then FFilterRecordEvent(self,p,Accept);
  730.    if Accept then begin
  731.     FillCurKeyValues;
  732.     Result:=Compare;
  733.     if Result then begin
  734.      Bookm:=FBookm.Value[p];
  735.      GotoBookmark(@Bookm);
  736.      exit;
  737.     end;
  738.    end;
  739.    inc(p);
  740.   end;
  741.  until not FetchNextBlock;
  742.  finally
  743.   sl2.Free;
  744.   sl1.Free;
  745.   FieldList.Free;
  746.  end;
  747. end;
  748.  
  749. function TVirtualDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;
  750.   const ResultFields: string): Variant;
  751. var
  752.   FieldList:THArrayInteger;
  753.   sl1,sl2:TStrings;
  754.   p,i:integer;
  755.   Accept:boolean;
  756.   Bookm1 : TBookmark;
  757.   Bookm2 : integer;
  758.  
  759.   function AnsiCompareCS(const v,w: string; CaseSensitive: boolean; PartialKey: boolean): boolean;
  760.   var s: string;
  761.   begin
  762.    if PartialKey
  763.     then s := Copy(w, 1, length(v))
  764.     else s := w;
  765.    if CaseSensitive
  766.     then Result := AnsiCompareStr(v,s)=0
  767.     else Result := AnsiCompareText(v,s)=0
  768.   end;
  769.  
  770.   function Compare: boolean;
  771.   var i: integer;
  772.   begin
  773.    Result:=True;
  774.    for i:=0 to sl1.Count-1 do
  775.     if not AnsiCompareCS(sl1[i],sl2[i],True,False) then begin
  776.      Result:=False;
  777.      exit;
  778.     end;
  779.   end;
  780.  
  781.   procedure FillCurKeyValues;
  782.   var i:integer;
  783.   begin
  784.    sl2.Clear;
  785.    for i:=0 to FieldList.Count-1 do sl2.Add(VarToStr(GetFieldValue(p,FieldList[i])))
  786.   end;
  787.  
  788.   function VGetFieldList(FieldList:THArrayInteger;const FieldNames:string):boolean;
  789.   var Pos,f:integer;
  790.   begin
  791.    Result:=True;
  792.    Pos:=1;
  793.    while Pos<=Length(FieldNames) do begin
  794.     Result:=True;
  795.     try
  796.      f:=GetFieldID(ExtractFieldName(FieldNames,Pos));
  797.      FieldList.AddValue(f);
  798.     except
  799.      Result:=False;
  800.     end;
  801.    end;
  802.   end;
  803.  
  804. begin
  805.  Result:=Null;
  806.  FieldList:=THArrayInteger.Create;
  807.  sl1:=TStringList.Create;
  808.  sl2:=TStringList.Create;
  809.  try
  810.   if not VGetFieldList(FieldList,KeyFields) then exit;
  811.   if FieldList.Count=1
  812.    then sl1.Add(VarToStr(KeyValues))
  813.    else for i:=0 to FieldList.Count-1 do
  814.           sl1.Add(VarToStr(KeyValues[i]));
  815.  
  816.   p:=0;
  817.  
  818. //  VReadAll;
  819.  repeat
  820.   while p<RecordCount do begin
  821.    Accept:=True;
  822.    if Filtered and Assigned(FFilterRecordEvent)
  823.     then FFilterRecordEvent(self,p,Accept);
  824.    if Accept then begin
  825.     FillCurKeyValues;
  826.     if Compare then begin
  827.      Bookm1:=GetBookmark; //τα∩ε∞Φφασ∞ ≥σΩ≤∙σσ ∩εδεµσφΦσ
  828.      Bookm2:=FBookm.Value[p];
  829.      GotoBookmark(@Bookm2); // ∩σ≡σ⌡εΣΦ∞ φα φαΘΣσφ≤■ τα∩Φ±ⁿ
  830.      Result:=FieldValues[ResultFields]; // ταßΦ≡ασ∞ φαΘΣσφ√σ Σαφφ√σ
  831.      GotoBookmark(Bookm1); // ΓετΓ≡α∙ασ∞±  εß≡α≥φε
  832.      exit;
  833.     end;
  834.    end;
  835.    inc(p);
  836.   end;
  837.  until not FetchNextBlock;
  838.  finally
  839.   sl2.Free;
  840.   sl1.Free;
  841.   FieldList.Free;
  842.  end;
  843. end;
  844.  
  845. procedure TVirtualDataSet.ReOpen;
  846. begin
  847.  Close;
  848.  Open;
  849. end;
  850.  
  851. function TVirtualDataSet.CompareBookmarks(Bookmark1,
  852.   Bookmark2: TBookmark): integer;
  853. const
  854.  RetCodes: array[Boolean, Boolean] of ShortInt = ((2,-1),(1,0));
  855. begin
  856.   { Check for uninitialized bookmarks }
  857.   Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
  858.   if Result = 2 then begin
  859.    if PBookmInfo(Bookmark1).Bookmark<PBookmInfo(Bookmark2).Bookmark
  860.     then Result := -1
  861.     else if PBookmInfo(Bookmark1).Bookmark>PBookmInfo(Bookmark2).Bookmark
  862.           then Result := 1
  863.           else Result := 0;
  864.   end;
  865. end;
  866.  
  867. procedure TVirtualDataSet.VReadAll;
  868. begin
  869.  while FetchNextBlock do;
  870. end;
  871.  
  872. procedure TVirtualDataSet.OpenAll;
  873. begin
  874.  Open;
  875.  VReadAll;
  876. end;
  877.  
  878. procedure TVirtualDataSet.InternalEdit;
  879. begin
  880.  memcpy(ActiveBuffer,OldBuffer,RecordSize);
  881. end;
  882.  
  883. procedure TVirtualDataSet.CopyStructure(DataSet: TDataSet);
  884. var i:integer;
  885. begin
  886.  FieldDefs.Clear;
  887.  for i:=0 to DataSet.FieldDefs.Count-1 do begin
  888.    FieldDefs.Add(DataSet.FieldDefs[i].Name,DataSet.FieldDefs[i].DataType,DataSet.FieldDefs[i].Size,DataSet.FieldDefs[i].Required);
  889.  end;
  890. end;
  891.  
  892. end.
  893.