← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« 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-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

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.