← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/fcl-db/src/bufdataset.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/fcl-db/src/bufdataset.pas
1
 
{
2
 
    This file is part of the Free Pascal run time library.
3
 
    Copyright (c) 1999-2006 by Joost van der Sluis, member of the
4
 
    Free Pascal development team
5
 
 
6
 
    BufDataset implementation
7
 
 
8
 
    See the file COPYING.FPC, included in this distribution,
9
 
    for details about the copyright.
10
 
 
11
 
    This program is distributed in the hope that it will be useful,
12
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
13
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
 
 
15
 
 **********************************************************************}
16
 
 
17
 
unit BufDataset;
18
 
 
19
 
{$mode objfpc}
20
 
{$h+}
21
 
 
22
 
interface
23
 
 
24
 
uses Classes,Sysutils,db,bufdataset_parser;
25
 
 
26
 
type
27
 
  TBufDataset = Class;
28
 
 
29
 
  TResolverErrorEvent = procedure(Sender: TObject; DataSet: TBufDataset; E: EUpdateError;
30
 
    UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
31
 
 
32
 
  { TBufBlobStream }
33
 
 
34
 
  PBlobBuffer = ^TBlobBuffer;
35
 
  TBlobBuffer = record
36
 
    FieldNo : integer;
37
 
    OrgBufID: integer;
38
 
    Buffer  : pointer;
39
 
    Size    : ptrint;
40
 
  end;
41
 
 
42
 
   TBufBlobStream = class(TStream)
43
 
  private
44
 
    FBlobBuffer : PBlobBuffer;
45
 
    FPosition   : ptrint;
46
 
    FDataset    : TBufDataset;
47
 
  protected
48
 
    function Read(var Buffer; Count: Longint): Longint; override;
49
 
    function Write(const Buffer; Count: Longint): Longint; override;
50
 
    function Seek(Offset: Longint; Origin: Word): Longint; override;
51
 
  public
52
 
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
53
 
  end;
54
 
 
55
 
  { TBufDataset }
56
 
 
57
 
  PBufRecLinkItem = ^TBufRecLinkItem;
58
 
  TBufRecLinkItem = record
59
 
    prior   : PBufRecLinkItem;
60
 
    next    : PBufRecLinkItem;
61
 
  end;
62
 
 
63
 
  PBufBookmark = ^TBufBookmark;
64
 
  TBufBookmark = record
65
 
    BookmarkData : PBufRecLinkItem;
66
 
    BookmarkFlag : TBookmarkFlag;
67
 
  end;
68
 
 
69
 
  PRecUpdateBuffer = ^TRecUpdateBuffer;
70
 
  TRecUpdateBuffer = record
71
 
    UpdateKind         : TUpdateKind;
72
 
    BookmarkData       : pointer;
73
 
    OldValuesBuffer    : pchar;
74
 
  end;
75
 
 
76
 
  PBufBlobField = ^TBufBlobField;
77
 
  TBufBlobField = record
78
 
    ConnBlobBuffer : array[0..11] of byte; // It's here where the db-specific data is stored
79
 
    BlobBuffer     : PBlobBuffer;
80
 
  end;
81
 
 
82
 
  TRecordsUpdateBuffer = array of TRecUpdateBuffer;
83
 
 
84
 
  TBufDataset = class(TDBDataSet)
85
 
  private
86
 
    FCurrentRecBuf  : PBufRecLinkItem;
87
 
    FLastRecBuf     : PBufRecLinkItem;
88
 
    FFirstRecBuf    : PBufRecLinkItem;
89
 
    FFilterBuffer   : pchar;
90
 
    FBRecordCount   : integer;
91
 
 
92
 
    FPacketRecords  : integer;
93
 
    FRecordSize     : Integer;
94
 
    FNullmaskSize   : byte;
95
 
    FOpen           : Boolean;
96
 
    FUpdateBuffer   : TRecordsUpdateBuffer;
97
 
    FCurrentUpdateBuffer : integer;
98
 
 
99
 
    FParser         : TBufDatasetParser;
100
 
 
101
 
    FFieldBufPositions : array of longint;
102
 
 
103
 
    FAllPacketsFetched : boolean;
104
 
    FOnUpdateError  : TResolverErrorEvent;
105
 
 
106
 
    FBlobBuffers      : array of PBlobBuffer;
107
 
    FUpdateBlobBuffers: array of PBlobBuffer;
108
 
 
109
 
    function  GetCurrentBuffer: PChar;
110
 
    procedure CalcRecordSize;
111
 
    function LoadBuffer(Buffer : PChar): TGetResult;
112
 
    function GetFieldSize(FieldDef : TFieldDef) : longint;
113
 
    function GetRecordUpdateBuffer : boolean;
114
 
    procedure SetPacketRecords(aValue : integer);
115
 
    function  IntAllocRecordBuffer: PChar;
116
 
    procedure DoFilterRecord(var Acceptable: Boolean);
117
 
    procedure ParseFilter(const AFilter: string);
118
 
  protected
119
 
    function GetNewBlobBuffer : PBlobBuffer;
120
 
    function GetNewWriteBlobBuffer : PBlobBuffer;
121
 
    procedure FreeBlobBuffer(var ABlobBuffer: PBlobBuffer);
122
 
    procedure SetRecNo(Value: Longint); override;
123
 
    function  GetRecNo: Longint; override;
124
 
    function GetChangeCount: integer; virtual;
125
 
    function  AllocRecordBuffer: PChar; override;
126
 
    procedure FreeRecordBuffer(var Buffer: PChar); override;
127
 
    procedure InternalInitRecord(Buffer: PChar); override;
128
 
    function  GetCanModify: Boolean; override;
129
 
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
130
 
    procedure InternalOpen; override;
131
 
    procedure InternalClose; override;
132
 
    function getnextpacket : integer;
133
 
    function GetRecordSize: Word; override;
134
 
    procedure InternalPost; override;
135
 
    procedure InternalCancel; Override;
136
 
    procedure InternalDelete; override;
137
 
    procedure InternalFirst; override;
138
 
    procedure InternalLast; override;
139
 
    procedure InternalSetToRecord(Buffer: PChar); override;
140
 
    procedure InternalGotoBookmark(ABookmark: Pointer); override;
141
 
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
142
 
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
143
 
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
144
 
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
145
 
    function IsCursorOpen: Boolean; override;
146
 
    function  GetRecordCount: Longint; override;
147
 
    procedure ApplyRecUpdate(UpdateKind : TUpdateKind); virtual;
148
 
    procedure SetOnUpdateError(const aValue: TResolverErrorEvent);
149
 
    procedure SetFilterText(const Value: String); override; {virtual;}
150
 
    procedure SetFiltered(Value: Boolean); override; {virtual;}
151
 
  {abstracts, must be overidden by descendents}
152
 
    function Fetch : boolean; virtual; abstract;
153
 
    function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; virtual; abstract;
154
 
    procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); virtual; abstract;
155
 
 
156
 
  public
157
 
    constructor Create(AOwner: TComponent); override;
158
 
    function GetFieldData(Field: TField; Buffer: Pointer;
159
 
      NativeFormat: Boolean): Boolean; override;
160
 
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
161
 
    procedure SetFieldData(Field: TField; Buffer: Pointer;
162
 
      NativeFormat: Boolean); override;
163
 
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
164
 
    procedure ApplyUpdates; virtual; overload;
165
 
    procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
166
 
    procedure CancelUpdates; virtual;
167
 
    destructor Destroy; override;
168
 
    function Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean; override;
169
 
    function UpdateStatus: TUpdateStatus; override;
170
 
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
171
 
    property ChangeCount : Integer read GetChangeCount;
172
 
  published
173
 
    property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
174
 
    property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
175
 
  end;
176
 
 
177
 
implementation
178
 
 
179
 
uses variants, dbconst;
180
 
 
181
 
{ ---------------------------------------------------------------------
182
 
    TBufDataSet
183
 
  ---------------------------------------------------------------------}
184
 
 
185
 
constructor TBufDataset.Create(AOwner : TComponent);
186
 
begin
187
 
  Inherited Create(AOwner);
188
 
  SetLength(FUpdateBuffer,0);
189
 
  SetLength(FBlobBuffers,0);
190
 
  SetLength(FUpdateBlobBuffers,0);
191
 
  BookmarkSize := sizeof(TBufBookmark);
192
 
  FParser := nil;
193
 
  FPacketRecords := 10;
194
 
end;
195
 
 
196
 
procedure TBufDataset.SetPacketRecords(aValue : integer);
197
 
begin
198
 
  if (aValue = -1) or (aValue > 0) then FPacketRecords := aValue
199
 
    else DatabaseError(SInvPacketRecordsValue);
200
 
end;
201
 
 
202
 
destructor TBufDataset.Destroy;
203
 
begin
204
 
  inherited destroy;
205
 
end;
206
 
 
207
 
Function TBufDataset.GetCanModify: Boolean;
208
 
begin
209
 
  Result:= False;
210
 
end;
211
 
 
212
 
function TBufDataset.intAllocRecordBuffer: PChar;
213
 
begin
214
 
  // Note: Only the internal buffers of TDataset provide bookmark information
215
 
  result := AllocMem(FRecordsize+sizeof(TBufRecLinkItem));
216
 
end;
217
 
 
218
 
function TBufDataset.AllocRecordBuffer: PChar;
219
 
begin
220
 
  result := AllocMem(FRecordsize + sizeof(TBufBookmark) + CalcfieldsSize);
221
 
// The records are initialised, or else the fields of an empty, just-opened dataset
222
 
// are not null
223
 
  InitRecord(result);
224
 
end;
225
 
 
226
 
procedure TBufDataset.FreeRecordBuffer(var Buffer: PChar);
227
 
begin
228
 
  ReAllocMem(Buffer,0);
229
 
end;
230
 
 
231
 
procedure TBufDataset.InternalOpen;
232
 
 
233
 
begin
234
 
  CalcRecordSize;
235
 
 
236
 
  FBRecordcount := 0;
237
 
 
238
 
  FFirstRecBuf := pointer(IntAllocRecordBuffer);
239
 
  FLastRecBuf := FFirstRecBuf;
240
 
  FCurrentRecBuf := FLastRecBuf;
241
 
 
242
 
  FAllPacketsFetched := False;
243
 
 
244
 
  FOpen:=True;
245
 
 
246
 
  // parse filter expression
247
 
  try
248
 
    ParseFilter(Filter);
249
 
  except
250
 
    // oops, a problem with parsing, clear filter for now
251
 
    on E: Exception do Filter := EmptyStr;
252
 
  end;
253
 
 
254
 
end;
255
 
 
256
 
procedure TBufDataset.InternalClose;
257
 
 
258
 
var pc : pchar;
259
 
    r  : integer;
260
 
 
261
 
begin
262
 
  FOpen:=False;
263
 
  FCurrentRecBuf := FFirstRecBuf;
264
 
  while assigned(FCurrentRecBuf) do
265
 
    begin
266
 
    pc := pointer(FCurrentRecBuf);
267
 
    FCurrentRecBuf := FCurrentRecBuf^.next;
268
 
    FreeRecordBuffer(pc);
269
 
    end;
270
 
 
271
 
  if Length(FUpdateBuffer) > 0 then
272
 
    begin
273
 
    for r := 0 to length(FUpdateBuffer)-1 do with FUpdateBuffer[r] do
274
 
      begin
275
 
      if assigned(BookmarkData) then
276
 
        FreeRecordBuffer(OldValuesBuffer);
277
 
      end;
278
 
    end;
279
 
  SetLength(FUpdateBuffer,0);
280
 
  
281
 
  for r := 0 to High(FBlobBuffers) do
282
 
    FreeBlobBuffer(FBlobBuffers[r]);
283
 
  for r := 0 to High(FUpdateBlobBuffers) do
284
 
    FreeBlobBuffer(FUpdateBlobBuffers[r]);
285
 
 
286
 
  SetLength(FBlobBuffers,0);
287
 
  SetLength(FUpdateBlobBuffers,0);
288
 
 
289
 
  FFirstRecBuf:= nil;
290
 
  SetLength(FFieldBufPositions,0);
291
 
 
292
 
  if assigned(FParser) then FreeAndNil(FParser);
293
 
end;
294
 
 
295
 
procedure TBufDataset.InternalFirst;
296
 
begin
297
 
// if FCurrentRecBuf = FLastRecBuf then the dataset is just opened and empty
298
 
// in which case InternalFirst should do nothing (bug 7211)
299
 
  if FCurrentRecBuf <> FLastRecBuf then
300
 
    FCurrentRecBuf := nil;
301
 
end;
302
 
 
303
 
procedure TBufDataset.InternalLast;
304
 
begin
305
 
  repeat
306
 
  until (getnextpacket < FPacketRecords) or (FPacketRecords = -1);
307
 
  if FLastRecBuf <> FFirstRecBuf then
308
 
    FCurrentRecBuf := FLastRecBuf;
309
 
end;
310
 
 
311
 
procedure unSetFieldIsNull(NullMask : pbyte;x : longint); //inline;
312
 
begin
313
 
  NullMask[x div 8] := (NullMask[x div 8]) and not (1 shl (x mod 8));
314
 
end;
315
 
 
316
 
procedure SetFieldIsNull(NullMask : pbyte;x : longint); //inline;
317
 
begin
318
 
  NullMask[x div 8] := (NullMask[x div 8]) or (1 shl (x mod 8));
319
 
end;
320
 
 
321
 
function GetFieldIsNull(NullMask : pbyte;x : longint) : boolean; //inline;
322
 
begin
323
 
  result := ord(NullMask[x div 8]) and (1 shl (x mod 8)) > 0
324
 
end;
325
 
 
326
 
function TBufDataset.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
327
 
 
328
 
var Acceptable : Boolean;
329
 
    SaveState: TDataSetState;
330
 
 
331
 
 
332
 
begin
333
 
  Result := grOK;
334
 
  repeat
335
 
  Acceptable := True;
336
 
  case GetMode of
337
 
    gmPrior :
338
 
      if not assigned(PBufRecLinkItem(FCurrentRecBuf)^.prior) then
339
 
        begin
340
 
        Result := grBOF;
341
 
        end
342
 
      else
343
 
        begin
344
 
        FCurrentRecBuf := PBufRecLinkItem(FCurrentRecBuf)^.prior;
345
 
        end;
346
 
    gmCurrent :
347
 
      if FCurrentRecBuf = FLastRecBuf then
348
 
        Result := grError;
349
 
    gmNext :
350
 
      if FCurrentRecBuf = FLastRecBuf then // Dataset is empty (just opened)
351
 
        begin
352
 
        if getnextpacket = 0 then result := grEOF;
353
 
        end
354
 
      else if FCurrentRecBuf = nil then FCurrentRecBuf := FFirstRecBuf
355
 
      else if (PBufRecLinkItem(FCurrentRecBuf)^.next = FLastRecBuf) then
356
 
        begin
357
 
        if getnextpacket > 0 then
358
 
          begin
359
 
          FCurrentRecBuf := PBufRecLinkItem(FCurrentRecBuf)^.next;
360
 
          end
361
 
        else
362
 
          begin
363
 
          result:=grEOF;
364
 
          end
365
 
        end
366
 
      else
367
 
        begin
368
 
        FCurrentRecBuf := PBufRecLinkItem(FCurrentRecBuf)^.next;
369
 
        end;
370
 
  end;
371
 
 
372
 
  if Result = grOK then
373
 
    begin
374
 
 
375
 
    with PBufBookmark(Buffer + FRecordSize)^ do
376
 
      begin
377
 
      BookmarkData := FCurrentRecBuf;
378
 
      BookmarkFlag := bfCurrent;
379
 
      end;
380
 
    move((pointer(FCurrentRecBuf)+sizeof(TBufRecLinkItem))^,buffer^,FRecordSize);
381
 
    GetCalcFields(Buffer);
382
 
 
383
 
    if Filtered then
384
 
      begin
385
 
      FFilterBuffer := Buffer;
386
 
      SaveState := SetTempState(dsFilter);
387
 
      DoFilterRecord(Acceptable);
388
 
      if (GetMode = gmCurrent) and not Acceptable then
389
 
        begin
390
 
        Acceptable := True;
391
 
        Result := grError;
392
 
        end;
393
 
      RestoreState(SaveState);
394
 
      end;
395
 
    end
396
 
  else if (Result = grError) and doCheck then
397
 
    DatabaseError('No record');
398
 
  until Acceptable;
399
 
end;
400
 
 
401
 
function TBufDataset.GetRecordUpdateBuffer : boolean;
402
 
 
403
 
var x : integer;
404
 
    CurrBuff : PChar;
405
 
 
406
 
begin
407
 
  GetBookmarkData(ActiveBuffer,@CurrBuff);
408
 
  if (FCurrentUpdateBuffer >= length(FUpdateBuffer)) or (FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData <> CurrBuff) then
409
 
   for x := 0 to high(FUpdateBuffer) do
410
 
    if FUpdateBuffer[x].BookmarkData = CurrBuff then
411
 
      begin
412
 
      FCurrentUpdateBuffer := x;
413
 
      break;
414
 
      end;
415
 
  Result := (FCurrentUpdateBuffer < length(FUpdateBuffer))  and (FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData = CurrBuff);
416
 
end;
417
 
 
418
 
procedure TBufDataset.InternalSetToRecord(Buffer: PChar);
419
 
begin
420
 
  FCurrentRecBuf := PBufBookmark(Buffer + FRecordSize)^.BookmarkData;
421
 
end;
422
 
 
423
 
procedure TBufDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
424
 
begin
425
 
  PBufBookmark(Buffer + FRecordSize)^.BookmarkData := pointer(Data^);
426
 
end;
427
 
 
428
 
procedure TBufDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
429
 
begin
430
 
  PBufBookmark(Buffer + FRecordSize)^.BookmarkFlag := Value;
431
 
end;
432
 
 
433
 
procedure TBufDataset.GetBookmarkData(Buffer: PChar; Data: Pointer);
434
 
begin
435
 
  pointer(Data^) := PBufBookmark(Buffer + FRecordSize)^.BookmarkData;
436
 
end;
437
 
 
438
 
function TBufDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
439
 
begin
440
 
  Result := PBufBookmark(Buffer + FRecordSize)^.BookmarkFlag;
441
 
end;
442
 
 
443
 
procedure TBufDataset.InternalGotoBookmark(ABookmark: Pointer);
444
 
begin
445
 
  // note that ABookMark should be a PBufBookmark. But this way it can also be
446
 
  // a pointer to a TBufRecLinkItem
447
 
  FCurrentRecBuf := pointer(ABookmark^);
448
 
end;
449
 
 
450
 
function TBufDataset.getnextpacket : integer;
451
 
 
452
 
var i : integer;
453
 
    pb : pchar;
454
 
    
455
 
begin
456
 
  if FAllPacketsFetched then
457
 
    begin
458
 
    result := 0;
459
 
    exit;
460
 
    end;
461
 
  i := 0;
462
 
  pb := pchar(pointer(FLastRecBuf)+sizeof(TBufRecLinkItem));
463
 
  while ((i < FPacketRecords) or (FPacketRecords = -1)) and (loadbuffer(pb) = grOk) do
464
 
    begin
465
 
    FLastRecBuf^.next := pointer(IntAllocRecordBuffer);
466
 
    FLastRecBuf^.next^.prior := FLastRecBuf;
467
 
    FLastRecBuf := FLastRecBuf^.next;
468
 
    pb := pchar(pointer(FLastRecBuf)+sizeof(TBufRecLinkItem));
469
 
    inc(i);
470
 
    end;
471
 
  FBRecordCount := FBRecordCount + i;
472
 
  result := i;
473
 
end;
474
 
 
475
 
function TBufDataset.GetFieldSize(FieldDef : TFieldDef) : longint;
476
 
 
477
 
begin
478
 
  case FieldDef.DataType of
479
 
    ftString,
480
 
      ftGuid,
481
 
      ftFixedChar: result := FieldDef.Size + 1;
482
 
    ftFixedWideChar,
483
 
      ftWideString:result := (FieldDef.Size + 1)*2;
484
 
    ftSmallint,
485
 
      ftInteger,
486
 
      ftword     : result := sizeof(longint);
487
 
    ftBoolean    : result := sizeof(wordbool);
488
 
    ftBCD        : result := sizeof(currency);
489
 
    ftFloat      : result := sizeof(double);
490
 
    ftLargeInt   : result := sizeof(largeint);
491
 
    ftTime,
492
 
      ftDate,
493
 
      ftDateTime : result := sizeof(TDateTime);
494
 
    ftBlob,
495
 
      ftMemo,
496
 
      ftGraphic,
497
 
      ftFmtMemo,
498
 
      ftParadoxOle,
499
 
      ftDBaseOle,
500
 
      ftTypedBinary,
501
 
      ftOraBlob,
502
 
      ftOraClob,
503
 
      ftWideMemo : result := sizeof(TBufBlobField)
504
 
  else Result := 10
505
 
  end;
506
 
 
507
 
end;
508
 
 
509
 
function TBufDataset.LoadBuffer(Buffer : PChar): TGetResult;
510
 
 
511
 
var NullMask        : pbyte;
512
 
    x               : longint;
513
 
    CreateblobField : boolean;
514
 
    BufBlob         : PBufBlobField;
515
 
 
516
 
begin
517
 
  if not Fetch then
518
 
    begin
519
 
    Result := grEOF;
520
 
    FAllPacketsFetched := True;
521
 
    Exit;
522
 
    end;
523
 
 
524
 
  NullMask := pointer(buffer);
525
 
  fillchar(Nullmask^,FNullmaskSize,0);
526
 
  inc(buffer,FNullmaskSize);
527
 
 
528
 
  for x := 0 to FieldDefs.count-1 do
529
 
    begin
530
 
    if not LoadField(FieldDefs[x],buffer,CreateblobField) then
531
 
      SetFieldIsNull(NullMask,x)
532
 
    else if CreateblobField then
533
 
      begin
534
 
      BufBlob := PBufBlobField(Buffer);
535
 
      BufBlob^.BlobBuffer := GetNewBlobBuffer;
536
 
      LoadBlobIntoBuffer(FieldDefs[x],BufBlob);
537
 
      end;
538
 
    inc(buffer,GetFieldSize(FieldDefs[x]));
539
 
    end;
540
 
  Result := grOK;
541
 
end;
542
 
 
543
 
function TBufDataset.GetCurrentBuffer: PChar;
544
 
begin
545
 
  if State = dsFilter then Result := FFilterBuffer
546
 
  else if state = dsCalcFields then Result := CalcBuffer
547
 
  else Result := ActiveBuffer;
548
 
end;
549
 
 
550
 
 
551
 
function TBufDataset.GetFieldData(Field: TField; Buffer: Pointer;
552
 
  NativeFormat: Boolean): Boolean;
553
 
begin
554
 
  Result := GetFieldData(Field, Buffer);
555
 
end;
556
 
 
557
 
function TBufDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
558
 
 
559
 
var CurrBuff : pchar;
560
 
 
561
 
begin
562
 
  Result := False;
563
 
  if state = dsOldValue then
564
 
    begin
565
 
    if not GetRecordUpdateBuffer then
566
 
      begin
567
 
      // There is no old value available
568
 
      result := false;
569
 
      exit;
570
 
      end;
571
 
    currbuff := FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer+sizeof(TBufRecLinkItem);
572
 
    end
573
 
  else
574
 
    begin
575
 
    CurrBuff := GetCurrentBuffer;
576
 
    if not assigned(CurrBuff) then
577
 
      begin
578
 
      result := false;
579
 
      exit;
580
 
      end;
581
 
    end;
582
 
 
583
 
  If Field.Fieldno > 0 then // If = 0, then calculated field or something similar
584
 
    begin
585
 
    if GetFieldIsnull(pbyte(CurrBuff),Field.Fieldno-1) then
586
 
      begin
587
 
      result := false;
588
 
      exit;
589
 
      end;
590
 
    if assigned(buffer) then
591
 
      begin
592
 
      inc(CurrBuff,FFieldBufPositions[Field.FieldNo-1]);
593
 
      Move(CurrBuff^, Buffer^, GetFieldSize(FieldDefs[Field.FieldNo-1]));
594
 
      end;
595
 
    Result := True;
596
 
    end
597
 
  else
598
 
    begin
599
 
    Inc(CurrBuff, GetRecordSize + Field.Offset);
600
 
    Result := Boolean(CurrBuff^);
601
 
    if result and assigned(Buffer) then
602
 
      begin
603
 
      inc(CurrBuff);
604
 
      Move(CurrBuff^, Buffer^, Field.Datasize);
605
 
      end;
606
 
    end;
607
 
end;
608
 
 
609
 
procedure TBufDataset.SetFieldData(Field: TField; Buffer: Pointer;
610
 
  NativeFormat: Boolean);
611
 
begin
612
 
  SetFieldData(Field,Buffer);
613
 
end;
614
 
 
615
 
procedure TBufDataset.SetFieldData(Field: TField; Buffer: Pointer);
616
 
 
617
 
var CurrBuff : pointer;
618
 
    NullMask : pbyte;
619
 
 
620
 
begin
621
 
  if not (state in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
622
 
    begin
623
 
    DatabaseErrorFmt(SNotEditing,[Name],self);
624
 
    exit;
625
 
    end;
626
 
  if state = dsFilter then  // Set the value into the 'temporary' FLastRecBuf buffer for Locate and Lookup
627
 
    CurrBuff := pointer(FLastRecBuf) + sizeof(TBufRecLinkItem)
628
 
  else
629
 
    CurrBuff := GetCurrentBuffer;
630
 
  If Field.Fieldno > 0 then // If = 0, then calculated field or something
631
 
    begin
632
 
    NullMask := CurrBuff;
633
 
 
634
 
    inc(CurrBuff,FFieldBufPositions[Field.FieldNo-1]);
635
 
    if assigned(buffer) then
636
 
      begin
637
 
      Move(Buffer^, CurrBuff^, GetFieldSize(FieldDefs[Field.FieldNo-1]));
638
 
      unSetFieldIsNull(NullMask,Field.FieldNo-1);
639
 
      end
640
 
    else
641
 
      SetFieldIsNull(NullMask,Field.FieldNo-1);
642
 
    end
643
 
  else
644
 
    begin
645
 
    Inc(CurrBuff, GetRecordSize + Field.Offset);
646
 
    Boolean(CurrBuff^) := Buffer <> nil;
647
 
    inc(CurrBuff);
648
 
    if assigned(Buffer) then
649
 
      Move(Buffer^, CurrBuff^, Field.Datasize);
650
 
    end;
651
 
  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
652
 
    DataEvent(deFieldChange, Ptrint(Field));
653
 
end;
654
 
 
655
 
procedure TBufDataset.InternalDelete;
656
 
 
657
 
begin
658
 
  GetBookmarkData(ActiveBuffer,@FCurrentRecBuf);
659
 
 
660
 
  if FCurrentRecBuf <> FFirstRecBuf then FCurrentRecBuf^.prior^.next := FCurrentRecBuf^.next
661
 
  else FFirstRecBuf := FCurrentRecBuf^.next;
662
 
 
663
 
  FCurrentRecBuf^.next^.prior :=  FCurrentRecBuf^.prior;
664
 
 
665
 
  if not GetRecordUpdateBuffer then
666
 
    begin
667
 
    FCurrentUpdateBuffer := length(FUpdateBuffer);
668
 
    SetLength(FUpdateBuffer,FCurrentUpdateBuffer+1);
669
 
 
670
 
    FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := pchar(FCurrentRecBuf);
671
 
    FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData := FCurrentRecBuf;
672
 
 
673
 
    FCurrentRecBuf := FCurrentRecBuf^.next;
674
 
    end
675
 
  else
676
 
    begin
677
 
    if FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind = ukModify then
678
 
      begin
679
 
      FCurrentRecBuf := FCurrentRecBuf^.next;
680
 
      FreeRecordBuffer(pchar(FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData));
681
 
      FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData := FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer;
682
 
      end
683
 
    else
684
 
      begin
685
 
      FCurrentRecBuf := FCurrentRecBuf^.next;
686
 
      FreeRecordBuffer(pchar(FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData));
687
 
      FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData := nil;  //this 'disables' the updatebuffer
688
 
      end;
689
 
    end;
690
 
 
691
 
  dec(FBRecordCount);
692
 
  FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukDelete;
693
 
end;
694
 
 
695
 
 
696
 
procedure TBufDataset.ApplyRecUpdate(UpdateKind : TUpdateKind);
697
 
 
698
 
begin
699
 
  raise EDatabaseError.Create(SApplyRecNotSupported);
700
 
end;
701
 
 
702
 
procedure TBufDataset.CancelUpdates;
703
 
 
704
 
var r              : Integer;
705
 
 
706
 
begin
707
 
  CheckBrowseMode;
708
 
 
709
 
  if Length(FUpdateBuffer) > 0 then
710
 
    begin
711
 
    r := Length(FUpdateBuffer) -1;
712
 
    while r > -1 do with FUpdateBuffer[r] do
713
 
      begin
714
 
      if assigned(FUpdateBuffer[r].BookmarkData) then
715
 
        begin
716
 
        if UpdateKind = ukModify then
717
 
          begin
718
 
          move(pchar(OldValuesBuffer+sizeof(TBufRecLinkItem))^,pchar(BookmarkData+sizeof(TBufRecLinkItem))^,FRecordSize);
719
 
          FreeRecordBuffer(OldValuesBuffer);
720
 
          end
721
 
        else if UpdateKind = ukDelete then
722
 
          begin
723
 
          if assigned(PBufRecLinkItem(BookmarkData)^.prior) then  // or else it was the first record
724
 
            PBufRecLinkItem(BookmarkData)^.prior^.next := BookmarkData
725
 
          else
726
 
            FFirstRecBuf := BookmarkData;
727
 
          PBufRecLinkItem(BookmarkData)^.next^.prior := BookmarkData;
728
 
          inc(FBRecordCount);
729
 
          end
730
 
        else if UpdateKind = ukInsert then
731
 
          begin
732
 
          if assigned(PBufRecLinkItem(BookmarkData)^.prior) then // or else it was the first record
733
 
            PBufRecLinkItem(BookmarkData)^.prior^.next := PBufRecLinkItem(BookmarkData)^.next
734
 
          else
735
 
            FFirstRecBuf := PBufRecLinkItem(BookmarkData)^.next;
736
 
          PBufRecLinkItem(BookmarkData)^.next^.prior := PBufRecLinkItem(BookmarkData)^.prior;
737
 
          // resync won't work if the currentbuffer is freed...
738
 
          if FCurrentRecBuf = BookmarkData then FCurrentRecBuf := FCurrentRecBuf^.next;
739
 
          FreeRecordBuffer(BookmarkData);
740
 
          dec(FBRecordCount);
741
 
          end;
742
 
        end;
743
 
      dec(r)
744
 
      end;
745
 
 
746
 
    SetLength(FUpdateBuffer,0);
747
 
    Resync([]);
748
 
    end;
749
 
end;
750
 
 
751
 
procedure TBufDataset.SetOnUpdateError(const AValue: TResolverErrorEvent);
752
 
 
753
 
begin
754
 
  FOnUpdateError := AValue;
755
 
end;
756
 
 
757
 
procedure TBufDataset.ApplyUpdates; // For backwards-compatibility
758
 
 
759
 
begin
760
 
  ApplyUpdates(0);
761
 
end;
762
 
 
763
 
procedure TBufDataset.ApplyUpdates(MaxErrors: Integer);
764
 
 
765
 
var r            : Integer;
766
 
    FailedCount  : integer;
767
 
    Response     : TResolverResponse;
768
 
    StoreRecBuf  : PBufRecLinkItem;
769
 
    AUpdateErr   : EUpdateError;
770
 
 
771
 
begin
772
 
  CheckBrowseMode;
773
 
 
774
 
  StoreRecBuf := FCurrentRecBuf;
775
 
 
776
 
  r := 0;
777
 
  FailedCount := 0;
778
 
  Response := rrApply;
779
 
  try
780
 
    while (r < Length(FUpdateBuffer)) and (Response <> rrAbort) do
781
 
      begin
782
 
      if assigned(FUpdateBuffer[r].BookmarkData) then
783
 
        begin
784
 
        InternalGotoBookmark(@FUpdateBuffer[r].BookmarkData);
785
 
        Resync([rmExact,rmCenter]);
786
 
        Response := rrApply;
787
 
        try
788
 
          ApplyRecUpdate(FUpdateBuffer[r].UpdateKind);
789
 
        except
790
 
          on E: EDatabaseError do
791
 
            begin
792
 
            Inc(FailedCount);
793
 
            if failedcount > word(MaxErrors) then Response := rrAbort
794
 
            else Response := rrSkip;
795
 
            if assigned(FOnUpdateError) then
796
 
              begin
797
 
              AUpdateErr := EUpdateError.Create(SOnUpdateError,E.Message,0,0,Exception(AcquireExceptionObject));
798
 
              FOnUpdateError(Self,Self,AUpdateErr,FUpdateBuffer[r].UpdateKind,Response);
799
 
              AUpdateErr.Free;
800
 
              if Response in [rrApply, rrIgnore] then dec(FailedCount);
801
 
              if Response = rrApply then dec(r);
802
 
              end
803
 
            else if Response = rrAbort then
804
 
              Raise EUpdateError.Create(SOnUpdateError,E.Message,0,0,Exception(AcquireExceptionObject));
805
 
            end
806
 
          else
807
 
            raise;
808
 
        end;
809
 
        if response in [rrApply, rrIgnore] then
810
 
          begin
811
 
          FreeRecordBuffer(FUpdateBuffer[r].OldValuesBuffer);
812
 
          FUpdateBuffer[r].BookmarkData := nil;
813
 
          end
814
 
        end;
815
 
      inc(r);
816
 
      end;
817
 
  finally
818
 
    if failedcount = 0 then
819
 
      begin
820
 
      SetLength(FUpdateBuffer,0);
821
 
 
822
 
      if assigned(FUpdateBlobBuffers) then for r:=0 to length(FUpdateBlobBuffers)-1 do
823
 
       if assigned(FUpdateBlobBuffers[r]) then
824
 
        begin
825
 
        if FUpdateBlobBuffers[r]^.OrgBufID >= 0 then
826
 
          begin
827
 
          Freemem(FBlobBuffers[FUpdateBlobBuffers[r]^.OrgBufID]^.Buffer);
828
 
          Dispose(FBlobBuffers[FUpdateBlobBuffers[r]^.OrgBufID]);
829
 
          FBlobBuffers[FUpdateBlobBuffers[r]^.OrgBufID] :=FUpdateBlobBuffers[r];
830
 
          end
831
 
        else
832
 
          begin
833
 
          setlength(FBlobBuffers,length(FBlobBuffers)+1);
834
 
          FUpdateBlobBuffers[r]^.OrgBufID := high(FBlobBuffers);
835
 
          FBlobBuffers[high(FBlobBuffers)] := FUpdateBlobBuffers[r];
836
 
          
837
 
          end;
838
 
        end;
839
 
      SetLength(FUpdateBlobBuffers,0);
840
 
      end;
841
 
 
842
 
    FCurrentRecBuf := StoreRecBuf;
843
 
    Resync([]);
844
 
  end;
845
 
end;
846
 
 
847
 
 
848
 
procedure TBufDataset.InternalCancel;
849
 
 
850
 
Var i            : integer;
851
 
 
852
 
begin
853
 
  if assigned(FUpdateBlobBuffers) then for i:=0 to length(FUpdateBlobBuffers)-1 do
854
 
   if assigned(FUpdateBlobBuffers[i]) and (FUpdateBlobBuffers[i]^.FieldNo>0) then
855
 
    begin
856
 
    Reallocmem(FUpdateBlobBuffers[i]^.Buffer,0);
857
 
    Dispose(FUpdateBlobBuffers[i]);
858
 
    FUpdateBlobBuffers[i] := nil;
859
 
    end;
860
 
end;
861
 
 
862
 
procedure TBufDataset.InternalPost;
863
 
 
864
 
Var tmpRecBuffer : PBufRecLinkItem;
865
 
    CurrBuff     : PChar;
866
 
    i            : integer;
867
 
    blobbuf      : tbufblobfield;
868
 
    NullMask     : pbyte;
869
 
 
870
 
begin
871
 
  inherited InternalPost;
872
 
  if assigned(FUpdateBlobBuffers) then for i:=0 to length(FUpdateBlobBuffers)-1 do
873
 
   if assigned(FUpdateBlobBuffers[i]) and (FUpdateBlobBuffers[i]^.FieldNo>0) then
874
 
    begin
875
 
    blobbuf.BlobBuffer := FUpdateBlobBuffers[i];
876
 
    CurrBuff := ActiveBuffer;
877
 
    NullMask := pbyte(CurrBuff);
878
 
 
879
 
    inc(CurrBuff,FFieldBufPositions[FUpdateBlobBuffers[i]^.FieldNo-1]);
880
 
    Move(blobbuf, CurrBuff^, GetFieldSize(FieldDefs[FUpdateBlobBuffers[i]^.FieldNo-1]));
881
 
    unSetFieldIsNull(NullMask,FUpdateBlobBuffers[i]^.FieldNo-1);
882
 
    
883
 
    FUpdateBlobBuffers[i]^.FieldNo := -1;
884
 
    end;
885
 
 
886
 
  if state = dsInsert then
887
 
    begin
888
 
    if GetBookmarkFlag(ActiveBuffer) = bfEOF then
889
 
      // Append
890
 
      FCurrentRecBuf := FLastRecBuf
891
 
    else
892
 
      // The active buffer is the newly created TDataset record,
893
 
      // from which the bookmark is set to the record where the new record should be
894
 
      // inserted
895
 
      GetBookmarkData(ActiveBuffer,@FCurrentRecBuf);
896
 
 
897
 
    // Create the new record buffer
898
 
    tmpRecBuffer := FCurrentRecBuf^.prior;
899
 
 
900
 
    FCurrentRecBuf^.prior := pointer(IntAllocRecordBuffer);
901
 
    FCurrentRecBuf^.prior^.next := FCurrentRecBuf;
902
 
    FCurrentRecBuf := FCurrentRecBuf^.prior;
903
 
    If assigned(tmpRecBuffer) then // if not, it's the first record
904
 
      begin
905
 
      FCurrentRecBuf^.prior := tmpRecBuffer;
906
 
      tmpRecBuffer^.next := FCurrentRecBuf
907
 
      end
908
 
    else
909
 
      FFirstRecBuf := FCurrentRecBuf;
910
 
 
911
 
    // Link the newly created record buffer to the newly created TDataset record
912
 
    with PBufBookmark(ActiveBuffer + FRecordSize)^ do
913
 
      begin
914
 
      BookmarkData := FCurrentRecBuf;
915
 
      BookmarkFlag := bfInserted;
916
 
      end;
917
 
      
918
 
    inc(FBRecordCount);
919
 
    end
920
 
  else
921
 
    GetBookmarkData(ActiveBuffer,@FCurrentRecBuf);
922
 
 
923
 
  if not GetRecordUpdateBuffer then
924
 
    begin
925
 
    FCurrentUpdateBuffer := length(FUpdateBuffer);
926
 
    SetLength(FUpdateBuffer,FCurrentUpdateBuffer+1);
927
 
 
928
 
    FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData := FCurrentRecBuf;
929
 
 
930
 
    if state = dsEdit then
931
 
      begin
932
 
      // Update the oldvalues-buffer
933
 
      FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := intAllocRecordBuffer;
934
 
      move(FCurrentRecBuf^,FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer^,FRecordSize+sizeof(TBufRecLinkItem));
935
 
      FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukModify;
936
 
      end
937
 
    else
938
 
      FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukInsert;
939
 
    end;
940
 
 
941
 
  CurrBuff := pchar(FCurrentRecBuf);
942
 
  inc(Currbuff,sizeof(TBufRecLinkItem));
943
 
  move(ActiveBuffer^,CurrBuff^,FRecordSize);
944
 
end;
945
 
 
946
 
procedure TBufDataset.CalcRecordSize;
947
 
 
948
 
var x : longint;
949
 
 
950
 
begin
951
 
  FNullmaskSize := 1+((FieldDefs.count-1) div 8);
952
 
  FRecordSize := FNullmaskSize;
953
 
  SetLength(FFieldBufPositions,FieldDefs.count);
954
 
  for x := 0 to FieldDefs.count-1 do
955
 
    begin
956
 
    FFieldBufPositions[x] := FRecordSize;
957
 
    inc(FRecordSize, GetFieldSize(FieldDefs[x]));
958
 
    end;
959
 
end;
960
 
 
961
 
function TBufDataset.GetRecordSize : Word;
962
 
 
963
 
begin
964
 
  result := FRecordSize + sizeof(TBufBookmark);
965
 
end;
966
 
 
967
 
function TBufDataset.GetChangeCount: integer;
968
 
 
969
 
begin
970
 
  result := length(FUpdateBuffer);
971
 
end;
972
 
 
973
 
 
974
 
procedure TBufDataset.InternalInitRecord(Buffer: PChar);
975
 
 
976
 
begin
977
 
  FillChar(Buffer^, FRecordSize, #0);
978
 
 
979
 
  fillchar(Buffer^,FNullmaskSize,255);
980
 
end;
981
 
 
982
 
procedure TBufDataset.SetRecNo(Value: Longint);
983
 
 
984
 
var recnr        : integer;
985
 
    TmpRecBuffer : PBufRecLinkItem;
986
 
 
987
 
begin
988
 
  checkbrowsemode;
989
 
  if value > RecordCount then
990
 
    begin
991
 
    repeat until (getnextpacket < FPacketRecords) or (value <= RecordCount) or (FPacketRecords = -1);
992
 
    if value > RecordCount then
993
 
      begin
994
 
      DatabaseError(SNoSuchRecord,self);
995
 
      exit;
996
 
      end;
997
 
    end;
998
 
  TmpRecBuffer := FFirstRecBuf;
999
 
  for recnr := 1 to value-1 do
1000
 
    TmpRecBuffer := TmpRecBuffer^.next;
1001
 
  GotoBookmark(@TmpRecBuffer);
1002
 
end;
1003
 
 
1004
 
function TBufDataset.GetRecNo: Longint;
1005
 
 
1006
 
Var SearchRecBuffer : PBufRecLinkItem;
1007
 
    TmpRecBuffer    : PBufRecLinkItem;
1008
 
    recnr           : integer;
1009
 
    abuf            : PChar;
1010
 
 
1011
 
begin
1012
 
  abuf := GetCurrentBuffer;
1013
 
  // If abuf isn't assigned, the recordset probably isn't opened.
1014
 
  if assigned(abuf) and (FBRecordCount>0) and (state <> dsInsert) then
1015
 
    begin
1016
 
    GetBookmarkData(abuf,@SearchRecBuffer);
1017
 
    TmpRecBuffer := FFirstRecBuf;
1018
 
    recnr := 1;
1019
 
    while TmpRecBuffer <> SearchRecBuffer do
1020
 
      begin
1021
 
      inc(recnr);
1022
 
      TmpRecBuffer := TmpRecBuffer^.next;
1023
 
      end;
1024
 
    result := recnr;
1025
 
    end
1026
 
  else result := 0;
1027
 
end;
1028
 
 
1029
 
function TBufDataset.IsCursorOpen: Boolean;
1030
 
 
1031
 
begin
1032
 
  Result := FOpen;
1033
 
end;
1034
 
 
1035
 
Function TBufDataset.GetRecordCount: Longint;
1036
 
 
1037
 
begin
1038
 
  Result := FBRecordCount;
1039
 
end;
1040
 
 
1041
 
Function TBufDataSet.UpdateStatus: TUpdateStatus;
1042
 
 
1043
 
begin
1044
 
  Result:=usUnmodified;
1045
 
  if GetRecordUpdateBuffer then
1046
 
    case FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind of
1047
 
      ukModify : Result := usModified;
1048
 
      ukInsert : Result := usInserted;
1049
 
      ukDelete : Result := usDeleted;
1050
 
    end;
1051
 
end;
1052
 
 
1053
 
function TbufDataset.GetNewBlobBuffer : PBlobBuffer;
1054
 
 
1055
 
var ABlobBuffer : PBlobBuffer;
1056
 
 
1057
 
begin
1058
 
  setlength(FBlobBuffers,length(FBlobBuffers)+1);
1059
 
  new(ABlobBuffer);
1060
 
  fillbyte(ABlobBuffer^,sizeof(ABlobBuffer^),0);
1061
 
  ABlobBuffer^.OrgBufID := high(FUpdateBlobBuffers);
1062
 
  FBlobBuffers[high(FBlobBuffers)] := ABlobBuffer;
1063
 
  result := ABlobBuffer;
1064
 
end;
1065
 
 
1066
 
function TbufDataset.GetNewWriteBlobBuffer : PBlobBuffer;
1067
 
 
1068
 
var ABlobBuffer : PBlobBuffer;
1069
 
 
1070
 
begin
1071
 
  setlength(FUpdateBlobBuffers,length(FUpdateBlobBuffers)+1);
1072
 
  new(ABlobBuffer);
1073
 
  fillbyte(ABlobBuffer^,sizeof(ABlobBuffer^),0);
1074
 
  FUpdateBlobBuffers[high(FUpdateBlobBuffers)] := ABlobBuffer;
1075
 
  result := ABlobBuffer;
1076
 
end;
1077
 
 
1078
 
procedure TBufDataset.FreeBlobBuffer(var ABlobBuffer: PBlobBuffer);
1079
 
 
1080
 
begin
1081
 
  if not Assigned(ABlobBuffer) then Exit;
1082
 
  FreeMem(ABlobBuffer^.Buffer, ABlobBuffer^.Size);
1083
 
  Dispose(ABlobBuffer);
1084
 
  ABlobBuffer := Nil;
1085
 
end;
1086
 
 
1087
 
function TBufBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
1088
 
 
1089
 
begin
1090
 
  Case Origin of
1091
 
    soFromBeginning : FPosition:=Offset;
1092
 
    soFromEnd       : FPosition:=FBlobBuffer^.Size+Offset;
1093
 
    soFromCurrent   : FpoSition:=FPosition+Offset;
1094
 
  end;
1095
 
  Result:=FPosition;
1096
 
end;
1097
 
 
1098
 
 
1099
 
function TBufBlobStream.Read(var Buffer; Count: Longint): Longint;
1100
 
 
1101
 
var ptr : pointer;
1102
 
 
1103
 
begin
1104
 
  if FPosition + count > FBlobBuffer^.Size then
1105
 
    count := FBlobBuffer^.Size-FPosition;
1106
 
  ptr := FBlobBuffer^.Buffer+FPosition;
1107
 
  move(ptr^,buffer,count);
1108
 
  inc(FPosition,count);
1109
 
  result := count;
1110
 
end;
1111
 
 
1112
 
function TBufBlobStream.Write(const Buffer; Count: Longint): Longint;
1113
 
 
1114
 
var ptr : pointer;
1115
 
 
1116
 
begin
1117
 
  ReAllocMem(FBlobBuffer^.Buffer,FPosition+Count);
1118
 
  ptr := FBlobBuffer^.Buffer+FPosition;
1119
 
  move(buffer,ptr^,count);
1120
 
  inc(FBlobBuffer^.Size,count);
1121
 
  inc(FPosition,count);
1122
 
  Result := count;
1123
 
end;
1124
 
 
1125
 
constructor TBufBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
1126
 
 
1127
 
var bufblob : TBufBlobField;
1128
 
 
1129
 
begin
1130
 
  FDataset := Field.DataSet as TBufDataset;
1131
 
  if mode = bmread then
1132
 
    begin
1133
 
    if not field.getData(@bufblob) then
1134
 
      DatabaseError(SFieldIsNull);
1135
 
    if not assigned(bufblob.BlobBuffer) then with FDataSet do
1136
 
      begin
1137
 
      FBlobBuffer := GetNewBlobBuffer;
1138
 
      bufblob.BlobBuffer := FBlobBuffer;
1139
 
      LoadBlobIntoBuffer(FieldDefs[field.FieldNo-1],@bufblob);
1140
 
      end
1141
 
    else
1142
 
      FBlobBuffer := bufblob.BlobBuffer;
1143
 
    end
1144
 
  else if mode=bmWrite then with FDataSet as TBufDataset do
1145
 
    begin
1146
 
    FBlobBuffer := GetNewWriteBlobBuffer;
1147
 
    FBlobBuffer^.FieldNo := Field.FieldNo;
1148
 
    if (field.getData(@bufblob)) and assigned(bufblob.BlobBuffer) then
1149
 
      FBlobBuffer^.OrgBufID := bufblob.BlobBuffer^.OrgBufID
1150
 
    else
1151
 
      FBlobBuffer^.OrgBufID := -1;
1152
 
    end;
1153
 
end;
1154
 
 
1155
 
function TBufDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
1156
 
 
1157
 
var bufblob : TBufBlobField;
1158
 
 
1159
 
begin
1160
 
  result := nil;
1161
 
  if mode=bmread then
1162
 
    begin
1163
 
    if not field.getData(@bufblob) then
1164
 
      exit;
1165
 
 
1166
 
    result := TBufBlobStream.Create(Field as tblobfield,bmread);
1167
 
    end
1168
 
  else if mode=bmWrite then
1169
 
    begin
1170
 
    if not (state in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
1171
 
      begin
1172
 
      DatabaseErrorFmt(SNotEditing,[Name],self);
1173
 
      exit;
1174
 
      end;
1175
 
 
1176
 
    result := TBufBlobStream.Create(Field as tblobfield,bmWrite);
1177
 
 
1178
 
    if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
1179
 
      DataEvent(deFieldChange, Ptrint(Field));
1180
 
    end;
1181
 
end;
1182
 
 
1183
 
procedure TBufDataset.DoFilterRecord(var Acceptable: Boolean);
1184
 
begin
1185
 
  Acceptable := true;
1186
 
  // check user filter
1187
 
  if Assigned(OnFilterRecord) then
1188
 
    OnFilterRecord(Self, Acceptable);
1189
 
 
1190
 
  // check filtertext
1191
 
  if Acceptable and (Length(Filter) > 0) then
1192
 
    Acceptable := Boolean((FParser.ExtractFromBuffer(GetCurrentBuffer))^);
1193
 
 
1194
 
end;
1195
 
 
1196
 
procedure TBufDataset.SetFilterText(const Value: String);
1197
 
begin
1198
 
  if Value = Filter then
1199
 
    exit;
1200
 
 
1201
 
  // parse
1202
 
  ParseFilter(Value);
1203
 
 
1204
 
  // call dataset method
1205
 
  inherited;
1206
 
 
1207
 
  // refilter dataset if filtered
1208
 
  if IsCursorOpen and Filtered then Refresh;
1209
 
end;
1210
 
 
1211
 
procedure TBufDataset.SetFiltered(Value: Boolean); {override;}
1212
 
begin
1213
 
  if Value = Filtered then
1214
 
    exit;
1215
 
 
1216
 
  // pass on to ancestor
1217
 
  inherited;
1218
 
 
1219
 
  // only refresh if active
1220
 
  if IsCursorOpen then
1221
 
    Refresh;
1222
 
end;
1223
 
 
1224
 
procedure TBufDataset.ParseFilter(const AFilter: string);
1225
 
begin
1226
 
  // parser created?
1227
 
  if Length(AFilter) > 0 then
1228
 
  begin
1229
 
    if (FParser = nil) and IsCursorOpen then
1230
 
    begin
1231
 
      FParser := TBufDatasetParser.Create(Self);
1232
 
    end;
1233
 
    // have a parser now?
1234
 
    if FParser <> nil then
1235
 
    begin
1236
 
      // set options
1237
 
      FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
1238
 
      FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
1239
 
      // parse expression
1240
 
      FParser.ParseExpression(AFilter);
1241
 
    end;
1242
 
  end;
1243
 
end;
1244
 
 
1245
 
 
1246
 
Function TBufDataset.Locate(const KeyFields: string; const KeyValues: Variant; options: TLocateOptions) : boolean;
1247
 
 
1248
 
 
1249
 
  function CompareText0(substr, astr: pchar; len : integer; options: TLocateOptions): integer;
1250
 
 
1251
 
  var
1252
 
    i : integer; Chr1, Chr2: byte;
1253
 
  begin
1254
 
    result := 0;
1255
 
    i := 0;
1256
 
    chr1 := 1;
1257
 
    while (result=0) and (i<len) and (chr1 <> 0) do
1258
 
      begin
1259
 
      Chr1 := byte(substr[i]);
1260
 
      Chr2 := byte(astr[i]);
1261
 
      inc(i);
1262
 
      if loCaseInsensitive in options then
1263
 
        begin
1264
 
        if Chr1 in [97..122] then
1265
 
          dec(Chr1,32);
1266
 
        if Chr2 in [97..122] then
1267
 
          dec(Chr2,32);
1268
 
        end;
1269
 
      result := Chr1 - Chr2;
1270
 
      end;
1271
 
    if (result <> 0) and (chr1 = 0) and (loPartialKey in options) then result := 0;
1272
 
  end;
1273
 
 
1274
 
 
1275
 
var keyfield    : TField;     // Field to search in
1276
 
    ValueBuffer : pchar;      // Pointer to value to search for, in TField' internal format
1277
 
    VBLength    : integer;
1278
 
 
1279
 
    FieldBufPos : PtrInt;     // Amount to add to the record buffer to get the FieldBuffer
1280
 
    CurrLinkItem: PBufRecLinkItem;
1281
 
    CurrBuff    : pchar;
1282
 
    bm          : TBufBookmark;
1283
 
 
1284
 
    CheckNull   : Boolean;
1285
 
    SaveState   : TDataSetState;
1286
 
 
1287
 
begin
1288
 
// For now it is only possible to search in one field at the same time
1289
 
  result := False;
1290
 
 
1291
 
  if IsEmpty then exit;
1292
 
 
1293
 
  keyfield := FieldByName(keyfields);
1294
 
  CheckNull := VarIsNull(KeyValues);
1295
 
 
1296
 
  if not CheckNull then
1297
 
    begin
1298
 
    SaveState := State;
1299
 
    SetTempState(dsFilter);
1300
 
    keyfield.Value := KeyValues;
1301
 
    RestoreState(SaveState);
1302
 
 
1303
 
    FieldBufPos := FFieldBufPositions[keyfield.FieldNo-1];
1304
 
    VBLength := keyfield.DataSize;
1305
 
    ValueBuffer := AllocMem(VBLength);
1306
 
    currbuff := pointer(FLastRecBuf)+sizeof(TBufRecLinkItem)+FieldBufPos;
1307
 
    move(currbuff^,ValueBuffer^,VBLength);
1308
 
    end;
1309
 
 
1310
 
  CurrLinkItem := FFirstRecBuf;
1311
 
 
1312
 
  if CheckNull then
1313
 
    begin
1314
 
    repeat
1315
 
    currbuff := pointer(CurrLinkItem)+sizeof(TBufRecLinkItem);
1316
 
    if GetFieldIsnull(pbyte(CurrBuff),keyfield.Fieldno-1) then
1317
 
      begin
1318
 
      result := True;
1319
 
      break;
1320
 
      end;
1321
 
    CurrLinkItem := CurrLinkItem^.next;
1322
 
    if CurrLinkItem = FLastRecBuf then getnextpacket;
1323
 
    until CurrLinkItem = FLastRecBuf;
1324
 
    end
1325
 
  else if keyfield.DataType = ftString then
1326
 
    begin
1327
 
    repeat
1328
 
    currbuff := pointer(CurrLinkItem)+sizeof(TBufRecLinkItem);
1329
 
    if not GetFieldIsnull(pbyte(CurrBuff),keyfield.Fieldno-1) then
1330
 
      begin
1331
 
      inc(CurrBuff,FieldBufPos);
1332
 
      if CompareText0(ValueBuffer,CurrBuff,VBLength,options) = 0 then
1333
 
        begin
1334
 
        result := True;
1335
 
        break;
1336
 
        end;
1337
 
      end;
1338
 
    CurrLinkItem := CurrLinkItem^.next;
1339
 
    if CurrLinkItem = FLastRecBuf then getnextpacket;
1340
 
    until CurrLinkItem = FLastRecBuf;
1341
 
    end
1342
 
  else
1343
 
    begin
1344
 
    repeat
1345
 
    currbuff := pointer(CurrLinkItem)+sizeof(TBufRecLinkItem);
1346
 
    if not GetFieldIsnull(pbyte(CurrBuff),keyfield.Fieldno-1) then
1347
 
      begin
1348
 
      inc(CurrBuff,FieldBufPos);
1349
 
      if CompareByte(ValueBuffer^,CurrBuff^,VBLength) = 0 then
1350
 
        begin
1351
 
        result := True;
1352
 
        break;
1353
 
        end;
1354
 
      end;
1355
 
 
1356
 
    CurrLinkItem := CurrLinkItem^.next;
1357
 
    if CurrLinkItem = FLastRecBuf then getnextpacket;
1358
 
    until CurrLinkItem = FLastRecBuf;
1359
 
    end;
1360
 
 
1361
 
 
1362
 
  if Result then
1363
 
    begin
1364
 
    bm.BookmarkData := CurrLinkItem;
1365
 
    bm.BookmarkFlag := bfCurrent;
1366
 
    GotoBookmark(@bm);
1367
 
    end;
1368
 
 
1369
 
  ReAllocmem(ValueBuffer,0);
1370
 
end;
1371
 
 
1372
 
begin
1373
 
end.