← 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/dbase/dbf_pgfile.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/dbase/dbf_pgfile.pas
 
1
unit dbf_pgfile;
 
2
 
 
3
interface
 
4
 
 
5
{$I dbf_common.inc}
 
6
 
 
7
uses
 
8
  Classes,
 
9
  SysUtils,
 
10
  dbf_common;
 
11
 
 
12
//const
 
13
//  MaxHeaders = 256;
 
14
 
 
15
type
 
16
  EPagedFile = Exception;
 
17
 
 
18
  TPagedFileMode = (pfNone, pfMemoryCreate, pfMemoryOpen, pfExclusiveCreate, 
 
19
    pfExclusiveOpen, pfReadWriteCreate, pfReadWriteOpen, pfReadOnly);
 
20
 
 
21
  // access levels:
 
22
  //
 
23
  // - memory            create
 
24
  // - exclusive         create/open
 
25
  // - read/write        create/open
 
26
  // - readonly                 open
 
27
  //
 
28
  // - memory            -*-share: N/A          -*-locks: disabled    -*-indexes: read/write
 
29
  // - exclusive_create  -*-share: deny write   -*-locks: disabled    -*-indexes: read/write
 
30
  // - exclusive_open    -*-share: deny write   -*-locks: disabled    -*-indexes: read/write
 
31
  // - readwrite_create  -*-share: deny none    -*-locks: enabled     -*-indexes: read/write
 
32
  // - readwrite_open    -*-share: deny none    -*-locks: enabled     -*-indexes: read/write
 
33
  // - readonly          -*-share: deny none    -*-locks: disabled    -*-indexes: readonly
 
34
 
 
35
  TPagedFile = class(TObject)
 
36
  protected
 
37
    FStream: TStream;
 
38
    FHeaderOffset: Integer;
 
39
    FHeaderSize: Integer;
 
40
    FRecordSize: Integer;
 
41
    FPageSize: Integer;         { need for MDX, where recordsize <> pagesize }
 
42
    FRecordCount: Integer;      { actually FPageCount, but we want to keep existing code }
 
43
    FPagesPerRecord: Integer;
 
44
    FCachedSize: Integer;
 
45
    FCachedRecordCount: Integer;
 
46
    FHeader: PChar;
 
47
    FActive: Boolean;
 
48
    FNeedRecalc: Boolean;
 
49
    FHeaderModified: Boolean;
 
50
    FPageOffsetByHeader: Boolean;   { do pages start after header or just at BOF? }
 
51
    FMode: TPagedFileMode;
 
52
    FTempMode: TPagedFileMode;
 
53
    FUserMode: TPagedFileMode;
 
54
    FAutoCreate: Boolean;
 
55
    FNeedLocks: Boolean;
 
56
    FVirtualLocks: Boolean;
 
57
    FFileLocked: Boolean;
 
58
    FFileName: string;
 
59
    FBufferPtr: Pointer;
 
60
    FBufferAhead: Boolean;
 
61
    FBufferPage: Integer;
 
62
    FBufferOffset: Integer;
 
63
    FBufferSize: Integer;
 
64
    FBufferReadSize: Integer;
 
65
    FBufferMaxSize: Integer;
 
66
    FBufferModified: Boolean;
 
67
    FWriteError: Boolean;
 
68
  protected
 
69
    procedure SetHeaderOffset(NewValue: Integer); virtual;
 
70
    procedure SetRecordSize(NewValue: Integer); virtual;
 
71
    procedure SetHeaderSize(NewValue: Integer); virtual;
 
72
    procedure SetPageSize(NewValue: Integer);
 
73
    procedure SetPageOffsetByHeader(NewValue: Boolean); virtual;
 
74
    procedure SetRecordCount(NewValue: Integer);
 
75
    procedure SetBufferAhead(NewValue: Boolean);
 
76
    procedure SetFileName(NewName: string);
 
77
    procedure SetStream(NewStream: TStream);
 
78
    function  LockSection(const Offset, Length: Cardinal; const Wait: Boolean): Boolean; virtual;
 
79
    function  UnlockSection(const Offset, Length: Cardinal): Boolean; virtual;
 
80
    procedure UpdateBufferSize;
 
81
    procedure RecalcPagesPerRecord;
 
82
    procedure ReadHeader;
 
83
    procedure FlushHeader;
 
84
    procedure FlushBuffer;
 
85
    function  ReadChar: Byte;
 
86
    procedure WriteChar(c: Byte);
 
87
    procedure CheckCachedSize(const APosition: Integer);
 
88
    procedure SynchronizeBuffer(IntRecNum: Integer);
 
89
    function  Read(Buffer: Pointer; ASize: Integer): Integer;
 
90
    function  ReadBlock(const BlockPtr: Pointer; const ASize, APosition: Integer): Integer;
 
91
    function  SingleReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
 
92
    procedure WriteBlock(const BlockPtr: Pointer; const ASize, APosition: Integer);
 
93
    procedure SingleWriteRecord(IntRecNum: Integer; Buffer: Pointer);
 
94
    function  GetRecordCount: Integer;
 
95
    procedure UpdateCachedSize(CurrPos: Integer);
 
96
 
 
97
    property VirtualLocks: Boolean read FVirtualLocks write FVirtualLocks;
 
98
  public
 
99
    constructor Create;
 
100
    destructor Destroy; override;
 
101
 
 
102
    procedure CloseFile; virtual;
 
103
    procedure OpenFile; virtual;
 
104
    procedure DeleteFile;
 
105
    procedure TryExclusive; virtual;
 
106
    procedure EndExclusive; virtual;
 
107
    procedure CheckExclusiveAccess;
 
108
    procedure DisableForceCreate;
 
109
    function  CalcPageOffset(const PageNo: Integer): Integer;
 
110
    function  IsRecordPresent(IntRecNum: Integer): boolean;
 
111
    function  ReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer; virtual;
 
112
    procedure WriteRecord(IntRecNum: Integer; Buffer: Pointer); virtual;
 
113
    procedure WriteHeader; virtual;
 
114
    function  FileCreated: Boolean;
 
115
    function  IsSharedAccess: Boolean;
 
116
    procedure ResetError;
 
117
 
 
118
    function  LockPage(const PageNo: Integer; const Wait: Boolean): Boolean;
 
119
    function  LockAllPages(const Wait: Boolean): Boolean;
 
120
    procedure UnlockPage(const PageNo: Integer);
 
121
    procedure UnlockAllPages;
 
122
 
 
123
    procedure Flush; virtual;
 
124
 
 
125
    property Active: Boolean read FActive;
 
126
    property AutoCreate: Boolean read FAutoCreate write FAutoCreate;   // only write when closed!
 
127
    property Mode: TPagedFileMode read FMode write FMode;              // only write when closed!
 
128
    property TempMode: TPagedFileMode read FTempMode;
 
129
    property NeedLocks: Boolean read FNeedLocks;
 
130
    property HeaderOffset: Integer read FHeaderOffset write SetHeaderOffset;
 
131
    property HeaderSize: Integer read FHeaderSize write SetHeaderSize;
 
132
    property RecordSize: Integer read FRecordSize write SetRecordSize;
 
133
    property PageSize: Integer read FPageSize write SetPageSize;
 
134
    property PagesPerRecord: Integer read FPagesPerRecord;
 
135
    property RecordCount: Integer read GetRecordCount write SetRecordCount;
 
136
    property CachedRecordCount: Integer read FCachedRecordCount;
 
137
    property PageOffsetByHeader: Boolean read FPageOffsetbyHeader write SetPageOffsetByHeader;
 
138
    property FileLocked: Boolean read FFileLocked;
 
139
    property Header: PChar read FHeader;
 
140
    property FileName: string read FFileName write SetFileName;
 
141
    property Stream: TStream read FStream write SetStream;
 
142
    property BufferAhead: Boolean read FBufferAhead write SetBufferAhead;
 
143
    property WriteError: Boolean read FWriteError;
 
144
  end;
 
145
 
 
146
implementation
 
147
 
 
148
uses
 
149
{$ifdef WINDOWS}
 
150
  Windows,
 
151
{$else}
 
152
{$ifdef KYLIX}
 
153
  Libc, 
 
154
{$endif}  
 
155
  Types, dbf_wtil,
 
156
{$endif}
 
157
  dbf_str;
 
158
 
 
159
//====================================================================
 
160
// TPagedFile
 
161
//====================================================================
 
162
constructor TPagedFile.Create;
 
163
begin
 
164
  FFileName := EmptyStr;
 
165
  FHeaderOffset := 0;
 
166
  FHeaderSize := 0;
 
167
  FRecordSize := 0;
 
168
  FRecordCount := 0;
 
169
  FPageSize := 0;
 
170
  FPagesPerRecord := 0;
 
171
  FActive := false;
 
172
  FHeaderModified := false;
 
173
  FPageOffsetByHeader := true;
 
174
  FNeedLocks := false;
 
175
  FMode := pfReadOnly;
 
176
  FTempMode := pfNone;
 
177
  FAutoCreate := false;
 
178
  FVirtualLocks := true;
 
179
  FFileLocked := false;
 
180
  FHeader := nil;
 
181
  FBufferPtr := nil;
 
182
  FBufferAhead := false;
 
183
  FBufferModified := false;
 
184
  FBufferSize := 0;
 
185
  FBufferMaxSize := 0;
 
186
  FBufferOffset := 0;
 
187
  FWriteError := false;
 
188
 
 
189
  inherited;
 
190
end;
 
191
 
 
192
destructor TPagedFile.Destroy;
 
193
begin
 
194
  // close physical file
 
195
  if FFileLocked then UnlockAllPages;
 
196
  CloseFile;
 
197
  FFileLocked := false;
 
198
 
 
199
  // free mem
 
200
  if FHeader <> nil then
 
201
    FreeMem(FHeader);
 
202
 
 
203
  inherited;
 
204
end;
 
205
 
 
206
procedure TPagedFile.OpenFile;
 
207
var
 
208
  fileOpenMode: Word;
 
209
begin
 
210
  if FActive then exit;  
 
211
 
 
212
  // store user specified mode
 
213
  FUserMode := FMode;
 
214
  if not (FMode in [pfMemoryCreate, pfMemoryOpen]) then
 
215
  begin
 
216
    // test if file exists
 
217
    if not FileExists(FFileName) then
 
218
    begin
 
219
      // if auto-creating, adjust mode
 
220
      if FAutoCreate then case FMode of
 
221
        pfExclusiveOpen:             FMode := pfExclusiveCreate;
 
222
        pfReadWriteOpen, pfReadOnly: FMode := pfReadWriteCreate;
 
223
      end;
 
224
      // it seems the VCL cannot share a file that is created?
 
225
      // create file first, then open it in requested mode
 
226
      // filecreated means 'to be created' in this context ;-)
 
227
      if FileCreated then
 
228
        FileClose(FileCreate(FFileName))
 
229
      else
 
230
        raise EPagedFile.CreateFmt(STRING_FILE_NOT_FOUND,[FFileName]);
 
231
    end;
 
232
    // specify open mode
 
233
    case FMode of
 
234
      pfExclusiveCreate: fileOpenMode := fmOpenReadWrite or fmShareDenyWrite;
 
235
      pfExclusiveOpen:   fileOpenMode := fmOpenReadWrite or fmShareDenyWrite;
 
236
      pfReadWriteCreate: fileOpenMode := fmOpenReadWrite or fmShareDenyNone;
 
237
      pfReadWriteOpen:   fileOpenMode := fmOpenReadWrite or fmShareDenyNone;
 
238
    else    // => readonly
 
239
                         fileOpenMode := fmOpenRead or fmShareDenyNone;
 
240
    end;
 
241
    // open file
 
242
    FStream := TFileStream.Create(FFileName, fileOpenMode);
 
243
    // if creating, then empty file
 
244
    if FileCreated then
 
245
      FStream.Size := 0;
 
246
  end else begin
 
247
    if FStream = nil then
 
248
    begin
 
249
      FMode := pfMemoryCreate;
 
250
      FStream := TMemoryStream.Create;
 
251
    end;
 
252
  end;
 
253
  // init size var
 
254
  FCachedSize := Stream.Size;
 
255
  // update whether we need locking
 
256
{$ifdef _DEBUG}
 
257
  FNeedLocks := true;
 
258
{$else}
 
259
  FNeedLocks := IsSharedAccess;
 
260
{$endif}
 
261
  FActive := true;
 
262
  // allocate memory for bufferahead
 
263
  UpdateBufferSize;
 
264
end;
 
265
 
 
266
procedure TPagedFile.CloseFile;
 
267
begin
 
268
  if FActive then
 
269
  begin
 
270
    FlushHeader;
 
271
    FlushBuffer;
 
272
    // don't free the user's stream
 
273
    if not (FMode in [pfMemoryOpen, pfMemoryCreate]) then
 
274
      FreeAndNil(FStream);
 
275
    // free bufferahead buffer
 
276
    FreeMemAndNil(FBufferPtr);
 
277
 
 
278
    // mode possibly overridden in case of auto-created file
 
279
    FMode := FUserMode;
 
280
    FActive := false;
 
281
    FCachedRecordCount := 0;
 
282
  end;
 
283
end;
 
284
 
 
285
procedure TPagedFile.DeleteFile;
 
286
begin
 
287
  // opened -> we can not delete
 
288
  if not FActive then
 
289
    SysUtils.DeleteFile(FileName);
 
290
end;
 
291
 
 
292
function TPagedFile.FileCreated: Boolean;
 
293
const
 
294
  CreationModes: array [pfNone..pfReadOnly] of Boolean =
 
295
    (false, true, false, true, false, true, false, false);
 
296
//   node, memcr, memop, excr, exopn, rwcr, rwopn, rdonly
 
297
begin
 
298
  Result := CreationModes[FMode];
 
299
end;
 
300
 
 
301
function TPagedFile.IsSharedAccess: Boolean;
 
302
const
 
303
  SharedAccessModes: array [pfNone..pfReadOnly] of Boolean =
 
304
    (false, false, false, false, false, true, true,  true);
 
305
//   node,  memcr, memop, excr,  exopn, rwcr, rwopn, rdonly
 
306
begin
 
307
  Result := SharedAccessModes[FMode];
 
308
end;
 
309
 
 
310
procedure TPagedFile.CheckExclusiveAccess;
 
311
begin
 
312
  // in-memory => exclusive access!
 
313
  if IsSharedAccess then
 
314
    raise EDbfError.Create(STRING_NEED_EXCLUSIVE_ACCESS);
 
315
end;
 
316
 
 
317
function TPagedFile.CalcPageOffset(const PageNo: Integer): Integer;
 
318
begin
 
319
  if not FPageOffsetByHeader then
 
320
    Result := FPageSize * PageNo
 
321
  else if PageNo = 0 then
 
322
    Result := 0
 
323
  else
 
324
    Result := FHeaderOffset + FHeaderSize + (FPageSize * (PageNo - 1))
 
325
end;
 
326
 
 
327
procedure TPagedFile.CheckCachedSize(const APosition: Integer);
 
328
begin
 
329
  // file expanded?
 
330
  if APosition > FCachedSize then
 
331
  begin
 
332
    FCachedSize := APosition;
 
333
    FNeedRecalc := true;
 
334
  end;
 
335
end;
 
336
 
 
337
function TPagedFile.Read(Buffer: Pointer; ASize: Integer): Integer;
 
338
begin
 
339
  // if we cannot read due to a lock, then wait a bit
 
340
  repeat
 
341
    Result := FStream.Read(Buffer^, ASize);
 
342
    if Result = 0 then
 
343
    begin
 
344
      // translation to linux???
 
345
      if GetLastError = ERROR_LOCK_VIOLATION then
 
346
      begin
 
347
        // wait a bit until block becomes available
 
348
        Sleep(1);
 
349
      end else begin
 
350
        // return empty block
 
351
        exit;
 
352
      end;
 
353
    end else
 
354
      exit;
 
355
  until false;
 
356
end;
 
357
 
 
358
procedure TPagedFile.UpdateCachedSize(CurrPos: Integer);
 
359
begin
 
360
  // have we added a record?
 
361
  if CurrPos > FCachedSize then
 
362
  begin
 
363
    // update cached size, always at end
 
364
    repeat
 
365
      Inc(FCachedSize, FRecordSize);
 
366
      Inc(FRecordCount, PagesPerRecord);
 
367
    until FCachedSize >= CurrPos;
 
368
  end;
 
369
end;
 
370
 
 
371
procedure TPagedFile.FlushBuffer;
 
372
begin
 
373
  if FBufferAhead and FBufferModified then
 
374
  begin
 
375
    WriteBlock(FBufferPtr, FBufferSize, FBufferOffset);
 
376
    FBufferModified := false;
 
377
  end;
 
378
end;
 
379
 
 
380
function TPagedFile.SingleReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
 
381
begin
 
382
  Result := ReadBlock(Buffer, RecordSize, CalcPageOffset(IntRecNum));
 
383
end;
 
384
 
 
385
procedure TPagedFile.SingleWriteRecord(IntRecNum: Integer; Buffer: Pointer);
 
386
begin
 
387
  WriteBlock(Buffer, RecordSize, CalcPageOffset(IntRecNum));
 
388
end;
 
389
 
 
390
procedure TPagedFile.SynchronizeBuffer(IntRecNum: Integer);
 
391
begin
 
392
  // record outside buffer, flush previous buffer
 
393
  FlushBuffer;
 
394
  // read new set of records
 
395
  FBufferPage := IntRecNum;
 
396
  FBufferOffset := CalcPageOffset(IntRecNum);
 
397
  if FBufferOffset + FBufferMaxSize > FCachedSize then
 
398
    FBufferReadSize := FCachedSize - FBufferOffset
 
399
  else
 
400
    FBufferReadSize := FBufferMaxSize;
 
401
  FBufferSize := FBufferReadSize;
 
402
  FBufferReadSize := ReadBlock(FBufferPtr, FBufferReadSize, FBufferOffset);
 
403
end;
 
404
 
 
405
function TPagedFile.IsRecordPresent(IntRecNum: Integer): boolean;
 
406
begin
 
407
  // if in shared mode, recordcount can only increase, check if recordno
 
408
  // in range for cached recordcount
 
409
  if not IsSharedAccess or (IntRecNum > FCachedRecordCount) then
 
410
    FCachedRecordCount := RecordCount;
 
411
  Result := (0 <= IntRecNum) and (IntRecNum <= FCachedRecordCount);
 
412
end;
 
413
 
 
414
function TPagedFile.ReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
 
415
var
 
416
  Offset: Integer;
 
417
begin
 
418
  if FBufferAhead then
 
419
  begin
 
420
    Offset := (IntRecNum - FBufferPage) * PageSize;
 
421
    if (FBufferPage <> -1) and (FBufferPage <= IntRecNum) and
 
422
        (Offset+RecordSize <= FBufferReadSize) then
 
423
    begin
 
424
      // have record in buffer, nothing to do here
 
425
    end else begin
 
426
      // need to update buffer
 
427
      SynchronizeBuffer(IntRecNum);
 
428
      // check if enough bytes read
 
429
      if RecordSize > FBufferReadSize then
 
430
      begin
 
431
        Result := 0;
 
432
        exit;
 
433
      end;
 
434
      // reset offset into buffer
 
435
      Offset := 0;
 
436
    end;
 
437
    // now we have this record in buffer
 
438
    Move(PChar(FBufferPtr)[Offset], Buffer^, RecordSize);
 
439
    // successful
 
440
    Result := RecordSize;
 
441
  end else begin
 
442
    // no buffering
 
443
    Result := SingleReadRecord(IntRecNum, Buffer);
 
444
  end;
 
445
end;
 
446
 
 
447
procedure TPagedFile.WriteRecord(IntRecNum: Integer; Buffer: Pointer);
 
448
var
 
449
  RecEnd: Integer;
 
450
begin
 
451
  if FBufferAhead then
 
452
  begin
 
453
    RecEnd := (IntRecNum - FBufferPage + PagesPerRecord) * PageSize;
 
454
    if (FBufferPage <> -1) and (FBufferPage <= IntRecNum) and
 
455
        (RecEnd <= FBufferMaxSize) then
 
456
    begin
 
457
      // extend buffer?
 
458
      if RecEnd > FBufferSize then
 
459
        FBufferSize := RecEnd;
 
460
    end else begin
 
461
      // record outside buffer, need to synchronize first
 
462
      SynchronizeBuffer(IntRecNum);
 
463
      RecEnd := PagesPerRecord * PageSize;
 
464
    end;
 
465
    // we can write this record to buffer
 
466
    Move(Buffer^, PChar(FBufferPtr)[RecEnd-RecordSize], RecordSize);
 
467
    FBufferModified := true;
 
468
    // update cached size
 
469
    UpdateCachedSize(FBufferOffset+RecEnd);
 
470
  end else begin
 
471
    // no buffering
 
472
    SingleWriteRecord(IntRecNum, Buffer);
 
473
    // update cached size
 
474
    UpdateCachedSize(FStream.Position);
 
475
  end;
 
476
end;
 
477
 
 
478
procedure TPagedFile.SetBufferAhead(NewValue: Boolean);
 
479
begin
 
480
  if FBufferAhead <> NewValue then
 
481
  begin
 
482
    FlushBuffer;
 
483
    FBufferAhead := NewValue;
 
484
    UpdateBufferSize;
 
485
  end;
 
486
end;
 
487
 
 
488
procedure TPagedFile.SetStream(NewStream: TStream);
 
489
begin
 
490
  if not FActive then
 
491
    FStream := NewStream;
 
492
end;
 
493
 
 
494
procedure TPagedFile.SetFileName(NewName: string);
 
495
begin
 
496
  if not FActive then
 
497
    FFileName := NewName;
 
498
end;
 
499
 
 
500
procedure TPagedFile.UpdateBufferSize;
 
501
begin
 
502
  if FBufferAhead then
 
503
  begin
 
504
    FBufferMaxSize := 65536;
 
505
    if RecordSize <> 0 then
 
506
      Dec(FBufferMaxSize, FBufferMaxSize mod PageSize);
 
507
  end else begin
 
508
    FBufferMaxSize := 0;
 
509
  end;
 
510
 
 
511
  if FBufferPtr <> nil then
 
512
    FreeMem(FBufferPtr);
 
513
  if FBufferAhead and (FBufferMaxSize <> 0) then
 
514
    GetMem(FBufferPtr, FBufferMaxSize)
 
515
  else
 
516
    FBufferPtr := nil;
 
517
  FBufferPage := -1;
 
518
  FBufferOffset := -1;
 
519
  FBufferModified := false;
 
520
end;
 
521
 
 
522
procedure TPagedFile.WriteHeader;
 
523
begin
 
524
  FHeaderModified := true;
 
525
  if FNeedLocks then
 
526
    FlushHeader;
 
527
end;
 
528
 
 
529
procedure TPagedFile.FlushHeader;
 
530
begin
 
531
  if FHeaderModified then
 
532
  begin
 
533
    FStream.Position := FHeaderOffset;
 
534
    FWriteError := (FStream.Write(FHeader^, FHeaderSize) = 0) or FWriteError;
 
535
    // test if written new header
 
536
    if FStream.Position > FCachedSize then
 
537
    begin
 
538
      // new header -> record count unknown
 
539
      FCachedSize := FStream.Position;
 
540
      FNeedRecalc := true;
 
541
    end;
 
542
    FHeaderModified := false;
 
543
  end;
 
544
end;
 
545
 
 
546
procedure TPagedFile.ReadHeader;
 
547
   { assumes header is large enough }
 
548
var
 
549
  size: Integer;
 
550
begin
 
551
  // save changes before reading new header
 
552
  FlushHeader;
 
553
  // check if header length zero
 
554
  if FHeaderSize <> 0 then
 
555
  begin
 
556
    // get size left in file for header
 
557
    size := FStream.Size - FHeaderOffset;
 
558
    // header start before EOF?
 
559
    if size >= 0 then
 
560
    begin
 
561
      // go to header start
 
562
      FStream.Position := FHeaderOffset;
 
563
      // whole header in file?
 
564
      if size >= FHeaderSize then
 
565
      begin
 
566
        // read header, nothing to be cleared
 
567
        Read(FHeader, FHeaderSize);
 
568
        size := FHeaderSize;
 
569
      end else begin
 
570
        // read what we can, clear rest
 
571
        Read(FHeader, size);
 
572
      end;
 
573
    end else begin
 
574
      // header start before EOF, clear header
 
575
      size := 0;
 
576
    end;
 
577
    FillChar(FHeader[size], FHeaderSize-size, 0);
 
578
  end;
 
579
end;
 
580
 
 
581
procedure TPagedFile.TryExclusive;
 
582
const NewTempMode: array[pfReadWriteCreate..pfReadOnly] of TPagedFileMode =
 
583
    (pfReadWriteOpen, pfReadWriteOpen, pfReadOnly);
 
584
begin
 
585
  // already in temporary exclusive mode?
 
586
  if (FTempMode = pfNone) and IsSharedAccess then
 
587
  begin
 
588
    // save temporary mode, if now creating, then reopen non-create
 
589
    FTempMode := NewTempMode[FMode];
 
590
    // try exclusive mode
 
591
    CloseFile;
 
592
    FMode := pfExclusiveOpen;
 
593
    try
 
594
      OpenFile;
 
595
    except
 
596
      on EFOpenError do
 
597
      begin
 
598
        // we failed, reopen normally
 
599
        EndExclusive;
 
600
      end;
 
601
    end;
 
602
  end;
 
603
end;
 
604
 
 
605
procedure TPagedFile.EndExclusive;
 
606
begin
 
607
  // are we in temporary file mode?
 
608
  if FTempMode <> pfNone then
 
609
  begin
 
610
    CloseFile;
 
611
    FMode := FTempMode;
 
612
    FTempMode := pfNone;
 
613
    OpenFile;
 
614
  end;
 
615
end;
 
616
 
 
617
procedure TPagedFile.DisableForceCreate;
 
618
begin
 
619
  case FMode of
 
620
    pfExclusiveCreate: FMode := pfExclusiveOpen;
 
621
    pfReadWriteCreate: FMode := pfReadWriteOpen;
 
622
  end;
 
623
end;
 
624
 
 
625
procedure TPagedFile.SetHeaderOffset(NewValue: Integer);
 
626
//
 
627
// *) assumes is called right before SetHeaderSize
 
628
//
 
629
begin
 
630
  if FHeaderOffset <> NewValue then
 
631
  begin
 
632
    FlushHeader;
 
633
    FHeaderOffset := NewValue;
 
634
  end;
 
635
end;
 
636
 
 
637
procedure TPagedFile.SetHeaderSize(NewValue: Integer);
 
638
begin
 
639
  if FHeaderSize <> NewValue then
 
640
  begin
 
641
    FlushHeader;
 
642
    if (FHeader <> nil) and (NewValue <> 0) then
 
643
      FreeMem(FHeader);
 
644
    FHeaderSize := NewValue;
 
645
    if FHeaderSize <> 0 then
 
646
      GetMem(FHeader, FHeaderSize);
 
647
    FNeedRecalc := true;
 
648
    ReadHeader;
 
649
  end;
 
650
end;
 
651
 
 
652
procedure TPagedFile.SetRecordSize(NewValue: Integer);
 
653
begin
 
654
  if FRecordSize <> NewValue then
 
655
  begin
 
656
    FRecordSize := NewValue;
 
657
    FPageSize := NewValue;
 
658
    FNeedRecalc := true;
 
659
    RecalcPagesPerRecord;
 
660
  end;
 
661
end;
 
662
 
 
663
procedure TPagedFile.SetPageSize(NewValue: Integer);
 
664
begin
 
665
  if FPageSize <> NewValue then
 
666
  begin
 
667
    FPageSize := NewValue;
 
668
    FNeedRecalc := true;
 
669
    RecalcPagesPerRecord;
 
670
    UpdateBufferSize;
 
671
  end;
 
672
end;
 
673
 
 
674
procedure TPagedFile.RecalcPagesPerRecord;
 
675
begin
 
676
  if FPageSize = 0 then
 
677
    FPagesPerRecord := 0
 
678
  else
 
679
    FPagesPerRecord := FRecordSize div FPageSize;
 
680
end;
 
681
 
 
682
function TPagedFile.GetRecordCount: Integer;
 
683
var
 
684
  currSize: Integer;
 
685
begin
 
686
  // file size changed?
 
687
  if FNeedLocks then
 
688
  begin
 
689
    currSize := FStream.Size;
 
690
    if currSize <> FCachedSize then
 
691
    begin
 
692
      FCachedSize := currSize;
 
693
      FNeedRecalc := true;
 
694
    end;
 
695
  end;
 
696
 
 
697
  // try to optimize speed
 
698
  if FNeedRecalc then
 
699
  begin
 
700
    // no file? test flags
 
701
    if (FPageSize = 0) or not FActive then
 
702
      FRecordCount := 0
 
703
    else
 
704
    if FPageOffsetByHeader then
 
705
      FRecordCount := (FCachedSize - FHeaderSize - FHeaderOffset) div FPageSize
 
706
    else
 
707
      FRecordCount := FCachedSize div FPageSize;
 
708
    if FRecordCount < 0 then
 
709
      FRecordCount := 0;
 
710
 
 
711
    // count updated
 
712
    FNeedRecalc := false;
 
713
  end;
 
714
  Result := FRecordCount;
 
715
end;
 
716
 
 
717
procedure TPagedFile.SetRecordCount(NewValue: Integer);
 
718
begin
 
719
  if RecordCount <> NewValue then
 
720
  begin
 
721
    if FPageOffsetByHeader then
 
722
      FCachedSize := FHeaderSize + FHeaderOffset + FPageSize * NewValue
 
723
    else
 
724
      FCachedSize := FPageSize * NewValue;
 
725
//    FCachedSize := CalcPageOffset(NewValue);
 
726
    FRecordCount := NewValue;
 
727
    FStream.Size := FCachedSize;
 
728
  end;
 
729
end;
 
730
 
 
731
procedure TPagedFile.SetPageOffsetByHeader(NewValue: Boolean);
 
732
begin
 
733
  if FPageOffsetByHeader <> NewValue then
 
734
  begin
 
735
    FPageOffsetByHeader := NewValue;
 
736
    FNeedRecalc := true;
 
737
  end;
 
738
end;
 
739
 
 
740
procedure TPagedFile.WriteChar(c: Byte);
 
741
begin
 
742
  FWriteError := (FStream.Write(c, 1) = 0) or FWriteError;
 
743
end;
 
744
 
 
745
function TPagedFile.ReadChar: Byte;
 
746
begin
 
747
  Read(@Result, 1);
 
748
end;
 
749
 
 
750
procedure TPagedFile.Flush;
 
751
begin
 
752
end;
 
753
 
 
754
function TPagedFile.ReadBlock(const BlockPtr: Pointer; const ASize, APosition: Integer): Integer;
 
755
begin
 
756
  FStream.Position := APosition;
 
757
  CheckCachedSize(APosition);
 
758
  Result := Read(BlockPtr, ASize);
 
759
end;
 
760
 
 
761
procedure TPagedFile.WriteBlock(const BlockPtr: Pointer; const ASize, APosition: Integer);
 
762
  // assumes a lock is held if necessary prior to calling this function
 
763
begin
 
764
  FStream.Position := APosition;
 
765
  CheckCachedSize(APosition);
 
766
  FWriteError := (FStream.Write(BlockPtr^, ASize) = 0) or FWriteError;
 
767
end;
 
768
 
 
769
procedure TPagedFile.ResetError;
 
770
begin
 
771
  FWriteError := false;
 
772
end;
 
773
 
 
774
// BDE compatible lock offset found!
 
775
const
 
776
{$ifdef WINDOWS}
 
777
  LockOffset = $EFFFFFFE;       // BDE compatible
 
778
  FileLockSize = 2;
 
779
{$else}
 
780
  LockOffset = $7FFFFFFF;
 
781
  FileLockSize = 1;
 
782
{$endif}
 
783
 
 
784
// dBase supports maximum of a billion records
 
785
  LockStart  = LockOffset - 1000000000;
 
786
 
 
787
function TPagedFile.LockSection(const Offset, Length: Cardinal; const Wait: Boolean): Boolean;
 
788
  // assumes FNeedLock = true
 
789
var
 
790
  Failed: Boolean;
 
791
begin
 
792
  // FNeedLocks => FStream is of type TFileStream
 
793
  Failed := false;
 
794
  repeat
 
795
    Result := LockFile(TFileStream(FStream).Handle, Offset, 0, Length, 0);
 
796
    // test if lock violation, then wait a bit and try again
 
797
    if not Result and Wait then
 
798
    begin
 
799
      if (GetLastError = ERROR_LOCK_VIOLATION) then
 
800
        Sleep(10)
 
801
      else
 
802
        Failed := true;
 
803
    end;
 
804
  until Result or not Wait or Failed;
 
805
end;
 
806
 
 
807
function TPagedFile.UnlockSection(const Offset, Length: Cardinal): Boolean;
 
808
begin
 
809
  Result := UnlockFile(TFileStream(FStream).Handle, Offset, 0, Length, 0);
 
810
end;
 
811
 
 
812
function TPagedFile.LockAllPages(const Wait: Boolean): Boolean;
 
813
var
 
814
  Offset: Cardinal;
 
815
  Length: Cardinal;
 
816
begin
 
817
  // do we need locking?
 
818
  if FNeedLocks and not FFileLocked then
 
819
  begin
 
820
    if FVirtualLocks then
 
821
    begin
 
822
{$ifdef SUPPORT_UINT32_CARDINAL}
 
823
      Offset := LockStart;
 
824
      Length := LockOffset - LockStart + FileLockSize;
 
825
{$else}
 
826
      // delphi 3 has strange types:
 
827
      // cardinal 0..2 GIG ?? does it produce correct code?
 
828
      Offset := Cardinal(LockStart);
 
829
      Length := Cardinal(LockOffset) - Cardinal(LockStart) + FileLockSize;
 
830
{$endif}
 
831
    end else begin
 
832
      Offset := 0;
 
833
      Length := $7FFFFFFF;
 
834
    end;
 
835
    // lock requested section
 
836
    Result := LockSection(Offset, Length, Wait);
 
837
    FFileLocked := Result;
 
838
  end else
 
839
    Result := true;
 
840
end;
 
841
 
 
842
procedure TPagedFile.UnlockAllPages;
 
843
var
 
844
  Offset: Cardinal;
 
845
  Length: Cardinal;
 
846
begin
 
847
  // do we need locking?
 
848
  if FNeedLocks and FFileLocked then
 
849
  begin
 
850
    if FVirtualLocks then
 
851
    begin
 
852
{$ifdef SUPPORT_UINT32_CARDINAL}
 
853
      Offset := LockStart;
 
854
      Length := LockOffset - LockStart + FileLockSize;
 
855
{$else}
 
856
      // delphi 3 has strange types:
 
857
      // cardinal 0..2 GIG ?? does it produce correct code?
 
858
      Offset := Cardinal(LockStart);
 
859
      Length := Cardinal(LockOffset) - Cardinal(LockStart) + FileLockSize;
 
860
{$endif}
 
861
    end else begin
 
862
      Offset := 0;
 
863
      Length := $7FFFFFFF;
 
864
    end;
 
865
    // unlock requested section
 
866
    // FNeedLocks => FStream is of type TFileStream
 
867
    FFileLocked := not UnlockSection(Offset, Length);
 
868
  end;
 
869
end;
 
870
 
 
871
function TPagedFile.LockPage(const PageNo: Integer; const Wait: Boolean): Boolean;
 
872
var
 
873
  Offset: Cardinal;
 
874
  Length: Cardinal;
 
875
begin
 
876
  // do we need locking?
 
877
  if FNeedLocks and not FFileLocked then
 
878
  begin
 
879
    if FVirtualLocks then
 
880
    begin
 
881
      Offset := LockOffset - Cardinal(PageNo);
 
882
      Length := 1;
 
883
    end else begin
 
884
      Offset := CalcPageOffset(PageNo);
 
885
      Length := RecordSize;
 
886
    end;
 
887
    // lock requested section
 
888
    Result := LockSection(Offset, Length, Wait);
 
889
  end else
 
890
    Result := true;
 
891
end;
 
892
 
 
893
procedure TPagedFile.UnlockPage(const PageNo: Integer);
 
894
var
 
895
  Offset: Cardinal;
 
896
  Length: Cardinal;
 
897
begin
 
898
  // do we need locking?
 
899
  if FNeedLocks and not FFileLocked then
 
900
  begin
 
901
    // calc offset + length
 
902
    if FVirtualLocks then
 
903
    begin
 
904
      Offset := LockOffset - Cardinal(PageNo);
 
905
      Length := 1;
 
906
    end else begin
 
907
      Offset := CalcPageOffset(PageNo);
 
908
      Length := RecordSize;
 
909
    end;
 
910
    // unlock requested section
 
911
    // FNeedLocks => FStream is of type TFileStream
 
912
    UnlockSection(Offset, Length);
 
913
  end;
 
914
end;
 
915
 
 
916
end.
 
917