paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-19 08:29:31 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ Implemented a filter-parser for TBufDataset, based on the parser of TDbf

Browse Source 
* TbufDataset is now a seperate unit

git-svn-id: trunk@5575 -
This commit is contained in:
joost 2006-12-11 21:58:09 +00:00
parent 9816de164a
commit 968f44d0b4
9 changed files with 1110 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -599,7 +599,8 @@ fcl/db/Dataset.txt svneol=native#text/plain
fcl/db/Makefile svneol=native#text/plain
fcl/db/Makefile.fpc svneol=native#text/plain
fcl/db/README -text
fcl/db/bufdataset.inc svneol=native#text/plain
fcl/db/bufdataset.pp svneol=native#text/plain
fcl/db/bufdataset_parser.pp svneol=native#text/plain
fcl/db/database.inc svneol=native#text/plain
fcl/db/dataset.inc svneol=native#text/plain
fcl/db/datasource.inc svneol=native#text/plain

166
fcl/db/Makefile
View File

@ -1,5 +1,5 @@
#
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2006/08/02]
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2006/12/11]
#
default: all
MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-palmos arm-wince arm-gba powerpc64-linux
@ -356,127 +356,127 @@ ifeq ($(FULL_TARGET),powerpc64-linux)
override TARGET_DIRS+=sdf memds sqldb unmaintained dbase sqlite
endif
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-go32v2)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-win32)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-os2)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-freebsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-beos)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-solaris)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-qnx)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-netware)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-openbsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-wdosx)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-darwin)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-emx)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-watcom)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-netwlibc)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-wince)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-freebsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-amiga)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-atari)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-openbsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),m68k-palmos)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc-amiga)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc-macos)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc-darwin)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc-morphos)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),sparc-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),sparc-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),sparc-solaris)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),x86_64-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),x86_64-freebsd)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),x86_64-win64)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),arm-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),arm-palmos)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),arm-wince)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),arm-gba)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override TARGET_UNITS+=dbconst db dbwhtml
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset
endif
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_RSTS+=dbwhtml dbconst
@ -603,127 +603,127 @@ override TARGET_RSTS+=dbwhtml dbconst
endif
override INSTALL_FPCPACKAGE=y
ifeq ($(FULL_TARGET),i386-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-go32v2)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-win32)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-os2)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-freebsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-beos)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-netbsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-solaris)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-qnx)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-netware)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-openbsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-wdosx)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-darwin)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-emx)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-watcom)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-netwlibc)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),i386-wince)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-freebsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-netbsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-amiga)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-atari)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-openbsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),m68k-palmos)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc-netbsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc-amiga)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc-macos)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc-darwin)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc-morphos)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),sparc-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),sparc-netbsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),sparc-solaris)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),x86_64-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),x86_64-freebsd)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),x86_64-win64)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),arm-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),arm-palmos)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),arm-wince)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),arm-gba)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override COMPILER_OPTIONS+=-S2
override COMPILER_OPTIONS+=-S2 -Fudbase -Fidbase
endif
ifdef REQUIRE_UNITSDIR
override UNITSDIR+=$(REQUIRE_UNITSDIR)

4
fcl/db/Makefile.fpc
View File

@ -15,11 +15,11 @@ dirs_netbsd=sqlite
dirs_openbsd=sqlite
dirs_win32=dbase sqlite
dirs_wince=dbase sqlite
units=dbconst db dbwhtml
units=dbconst db dbwhtml bufdataset_parser bufdataset
rsts=dbwhtml dbconst
[compiler]
options=-S2
options=-S2 -Fudbase -Fidbase
[install]
fpcpackage=y

249
fcl/db/bufdataset.inc → fcl/db/bufdataset.pp
View File

@ -1,6 +1,6 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Michael Van Canneyt, member of the
Copyright (c) 1999-2006 by Joost van der Sluis, member of the
Free Pascal development team
BufDataset implementation
@ -13,6 +13,170 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit BufDataset;
{$mode objfpc}
{$h+}
interface
uses Classes,Sysutils,db,bufdataset_parser;
type
TBufDataset = Class;
TResolverErrorEvent = procedure(Sender: TObject; DataSet: TBufDataset; E: EUpdateError;
UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
{ TBufBlobStream }
PBlobBuffer = ^TBlobBuffer;
TBlobBuffer = record
FieldNo : integer;
OrgBufID: integer;
Buffer : pointer;
Size : ptrint;
end;
TBufBlobStream = class(TStream)
private
FBlobBuffer : PBlobBuffer;
FPosition : ptrint;
FDataset : TBufDataset;
protected
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
public
constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
end;
{ TBufDataset }
PBufRecLinkItem = ^TBufRecLinkItem;
TBufRecLinkItem = record
prior : PBufRecLinkItem;
next : PBufRecLinkItem;
end;
PBufBookmark = ^TBufBookmark;
TBufBookmark = record
BookmarkData : PBufRecLinkItem;
BookmarkFlag : TBookmarkFlag;
end;
PRecUpdateBuffer = ^TRecUpdateBuffer;
TRecUpdateBuffer = record
UpdateKind : TUpdateKind;
BookmarkData : pointer;
OldValuesBuffer : pchar;
end;
PBufBlobField = ^TBufBlobField;
TBufBlobField = record
ConnBlobBuffer : array[0..11] of byte; // It's here where the db-specific data is stored
BlobBuffer : PBlobBuffer;
end;
TRecordsUpdateBuffer = array of TRecUpdateBuffer;
TBufDataset = class(TDBDataSet)
private
FCurrentRecBuf : PBufRecLinkItem;
FLastRecBuf : PBufRecLinkItem;
FFirstRecBuf : PBufRecLinkItem;
FFilterBuffer : pchar;
FBRecordCount : integer;
FPacketRecords : integer;
FRecordSize : Integer;
FNullmaskSize : byte;
FOpen : Boolean;
FUpdateBuffer : TRecordsUpdateBuffer;
FCurrentUpdateBuffer : integer;
FParser : TBufDatasetParser;
FFieldBufPositions : array of longint;
FAllPacketsFetched : boolean;
FOnUpdateError : TResolverErrorEvent;
FBlobBuffers : array of PBlobBuffer;
FUpdateBlobBuffers: array of PBlobBuffer;
function GetCurrentBuffer: PChar;
procedure CalcRecordSize;
function LoadBuffer(Buffer : PChar): TGetResult;
function GetFieldSize(FieldDef : TFieldDef) : longint;
function GetRecordUpdateBuffer : boolean;
procedure SetPacketRecords(aValue : integer);
function IntAllocRecordBuffer: PChar;
procedure DoFilterRecord(var Acceptable: Boolean);
procedure ParseFilter(const AFilter: string);
protected
function GetNewBlobBuffer : PBlobBuffer;
function GetNewWriteBlobBuffer : PBlobBuffer;
procedure SetRecNo(Value: Longint); override;
function GetRecNo: Longint; override;
function GetChangeCount: integer; virtual;
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure InternalInitRecord(Buffer: PChar); override;
function GetCanModify: Boolean; override;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
procedure InternalOpen; override;
procedure InternalClose; override;
function getnextpacket : integer;
function GetRecordSize: Word; override;
procedure InternalPost; override;
procedure InternalCancel; Override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalLast; override;
procedure InternalSetToRecord(Buffer: PChar); override;
procedure InternalGotoBookmark(ABookmark: Pointer); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
function IsCursorOpen: Boolean; override;
function GetRecordCount: Longint; override;
procedure ApplyRecUpdate(UpdateKind : TUpdateKind); virtual;
procedure SetOnUpdateError(const aValue: TResolverErrorEvent);
procedure SetFilterText(const Value: String); override; {virtual;}
procedure SetFiltered(Value: Boolean); override; {virtual;}
{abstracts, must be overidden by descendents}
function Fetch : boolean; virtual; abstract;
function LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean; virtual; abstract;
procedure LoadBlobIntoStream(Field: TField;AStream: TStream); virtual; abstract;
public
constructor Create(AOwner: TComponent); override;
function GetFieldData(Field: TField; Buffer: Pointer;
NativeFormat: Boolean): Boolean; override;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
procedure SetFieldData(Field: TField; Buffer: Pointer;
NativeFormat: Boolean); override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
procedure ApplyUpdates; virtual; overload;
procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
procedure CancelUpdates; virtual;
destructor Destroy; override;
function Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean; override;
function UpdateStatus: TUpdateStatus; override;
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
property ChangeCount : Integer read GetChangeCount;
published
property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
end;
implementation
uses variants, dbconst;
{ ---------------------------------------------------------------------
TBufDataSet
---------------------------------------------------------------------}
@ -24,6 +188,7 @@ begin
SetLength(FBlobBuffers,0);
SetLength(FUpdateBlobBuffers,0);
BookmarkSize := sizeof(TBufBookmark);
FParser := nil;
FPacketRecords := 10;
end;
@ -74,7 +239,17 @@ begin
FCurrentRecBuf := FLastRecBuf;
FAllPacketsFetched := False;
FOpen:=True;
// parse filter expression
try
ParseFilter(Filter);
except
// oops, a problem with parsing, clear filter for now
on E: Exception do Filter := EmptyStr;
end;
end;
procedure TBufDataset.InternalClose;
@ -104,6 +279,8 @@ begin
FFirstRecBuf:= nil;
SetLength(FFieldBufPositions,0);
if assigned(FParser) then FreeAndNil(FParser);
end;
procedure TBufDataset.InternalFirst;
@ -199,6 +376,11 @@ begin
FFilterBuffer := Buffer;
SaveState := SetTempState(dsFilter);
DoFilterRecord(Acceptable);
if (GetMode = gmCurrent) and not Acceptable then
begin
Acceptable := True;
Result := grError;
end;
RestoreState(SaveState);
end;
end
@ -931,16 +1113,67 @@ end;
procedure TBufDataset.DoFilterRecord(var Acceptable: Boolean);
begin
// check filtertext
if Length(Filter) > 0 then
begin
end;
Acceptable := true;
// check user filter
if Acceptable and Assigned(OnFilterRecord) then
if Assigned(OnFilterRecord) then
OnFilterRecord(Self, Acceptable);
// check filtertext
if Acceptable and (Length(Filter) > 0) then
Acceptable := Boolean((FParser.ExtractFromBuffer(GetCurrentBuffer))^);
end;
procedure TBufDataset.SetFilterText(const Value: String);
begin
if Value = Filter then
exit;
// parse
ParseFilter(Value);
// call dataset method
inherited;
// refilter dataset if filtered
if IsCursorOpen and Filtered then Refresh;
end;
procedure TBufDataset.SetFiltered(Value: Boolean); {override;}
begin
if Value = Filtered then
exit;
// pass on to ancestor
inherited;
// only refresh if active
if IsCursorOpen then
Refresh;
end;
procedure TBufDataset.ParseFilter(const AFilter: string);
begin
// parser created?
if Length(AFilter) > 0 then
begin
if (FParser = nil) and IsCursorOpen then
begin
FParser := TBufDatasetParser.Create(Self);
end;
// have a parser now?
if FParser <> nil then
begin
// set options
FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
// parse expression
FParser.ParseExpression(AFilter);
end;
end;
end;
Function TBufDataset.Locate(const KeyFields: string; const KeyValues: Variant; options: TLocateOptions) : boolean;
@ -1067,3 +1300,5 @@ begin
ReAllocmem(ValueBuffer,0);
end;
begin
end.

772
fcl/db/bufdataset_parser.pp Normal file
View File

@ -0,0 +1,772 @@
unit bufdataset_parser;
{$h+}
{$mode delphi}
interface
uses
SysUtils,
Classes,
db,
dbf_prscore,
dbf_prsdef;
type
TBufDatasetParser = class(TCustomExpressionParser)
private
FDataset: TDataSet;
FFieldVarList: TStringList;
FResultLen: Integer;
FIsExpression: Boolean; // expression or simple field?
FFieldType: TExpressionType;
FCaseInsensitive: Boolean;
FPartialMatch: boolean;
protected
FCurrentExpression: string;
procedure FillExpressList; override;
procedure HandleUnknownVariable(VarName: string); override;
function GetVariableInfo(VarName: string): TField;
function CurrentExpression: string; override;
function GetResultType: TExpressionType; override;
procedure SetCaseInsensitive(NewInsensitive: Boolean);
procedure SetPartialMatch(NewPartialMatch: boolean);
public
constructor Create(ADataset: TDataset);
destructor Destroy; override;
procedure ClearExpressions; override;
procedure ParseExpression(AExpression: string); virtual;
function ExtractFromBuffer(Buffer: PChar): PChar; virtual;
property Dataset: TDataSet read FDataset; // write FDataset;
property Expression: string read FCurrentExpression;
property ResultLen: Integer read FResultLen;
property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive;
property PartialMatch: boolean read FPartialMatch write SetPartialMatch;
end;
implementation
uses dbf_parser, dbconst;
type
// TFieldVar aids in retrieving field values from records
// in their proper type
TFieldVar = class(TObject)
private
FField: TField;
FFieldName: string;
FExprWord: TExprWord;
protected
function GetFieldVal: Pointer; virtual; abstract;
function GetFieldType: TExpressionType; virtual; abstract;
public
constructor Create(UseField: TField);
procedure Refresh(Buffer: PChar); virtual; abstract;
property FieldVal: Pointer read GetFieldVal;
property FieldDef: TField read FField;
property FieldType: TExpressionType read GetFieldType;
property FieldName: string read FFieldName;
end;
TStringFieldVar = class(TFieldVar)
protected
FFieldVal: PChar;
function GetFieldVal: Pointer; override;
function GetFieldType: TExpressionType; override;
public
constructor Create(UseField: TField);
destructor Destroy; override;
procedure Refresh(Buffer: PChar); override;
end;
TFloatFieldVar = class(TFieldVar)
private
FFieldVal: Double;
protected
function GetFieldVal: Pointer; override;
function GetFieldType: TExpressionType; override;
public
procedure Refresh(Buffer: PChar); override;
end;
TIntegerFieldVar = class(TFieldVar)
private
FFieldVal: Integer;
protected
function GetFieldVal: Pointer; override;
function GetFieldType: TExpressionType; override;
public
procedure Refresh(Buffer: PChar); override;
end;
TLargeIntFieldVar = class(TFieldVar)
private
FFieldVal: Int64;
protected
function GetFieldVal: Pointer; override;
function GetFieldType: TExpressionType; override;
public
procedure Refresh(Buffer: PChar); override;
end;
TDateTimeFieldVar = class(TFieldVar)
private
FFieldVal: TDateTime;
function GetFieldType: TExpressionType; override;
protected
function GetFieldVal: Pointer; override;
public
procedure Refresh(Buffer: PChar); override;
end;
TBooleanFieldVar = class(TFieldVar)
private
FFieldVal: wordbool;
function GetFieldType: TExpressionType; override;
protected
function GetFieldVal: Pointer; override;
public
procedure Refresh(Buffer: PChar); override;
end;
//--TFieldVar----------------------------------------------------------------
constructor TFieldVar.Create(UseField: TField);
begin
inherited Create;
// store field
//FDataset := ADataset;
FField := UseField;
FFieldName := UseField.FieldName;
end;
//--TStringFieldVar-------------------------------------------------------------
function TStringFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
end;
function TStringFieldVar.GetFieldType: TExpressionType;
begin
Result := etString;
end;
constructor TStringFieldVar.Create(UseField: TField);
begin
inherited;
GetMem(FFieldVal, dsMaxStringSize+1);
end;
destructor TStringFieldVar.Destroy;
begin
FreeMem(FFieldVal);
inherited;
end;
procedure TStringFieldVar.Refresh(Buffer: PChar);
var Fieldbuf : TStringFieldBuffer;
s : string;
begin
if not FField.DataSet.GetFieldData(FField,@Fieldbuf) then
s := ''
else
s := Fieldbuf;
strcopy(FFieldVal,@s[1]);
end;
//--TFloatFieldVar-----------------------------------------------------------
function TFloatFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
end;
function TFloatFieldVar.GetFieldType: TExpressionType;
begin
Result := etFloat;
end;
procedure TFloatFieldVar.Refresh(Buffer: PChar);
begin
if not FField.DataSet.GetFieldData(FField,@FFieldVal) then
FFieldVal := 0;
end;
//--TIntegerFieldVar----------------------------------------------------------
function TIntegerFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
end;
function TIntegerFieldVar.GetFieldType: TExpressionType;
begin
Result := etInteger;
end;
procedure TIntegerFieldVar.Refresh(Buffer: PChar);
begin
if not FField.DataSet.GetFieldData(FField,@FFieldVal) then
FFieldVal := 0;
end;
//--TLargeIntFieldVar----------------------------------------------------------
function TLargeIntFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
end;
function TLargeIntFieldVar.GetFieldType: TExpressionType;
begin
Result := etLargeInt;
end;
procedure TLargeIntFieldVar.Refresh(Buffer: PChar);
begin
if not FField.DataSet.GetFieldData(FField,@FFieldVal) then
FFieldVal := 0;
end;
//--TDateTimeFieldVar---------------------------------------------------------
function TDateTimeFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
end;
function TDateTimeFieldVar.GetFieldType: TExpressionType;
begin
Result := etDateTime;
end;
procedure TDateTimeFieldVar.Refresh(Buffer: PChar);
begin
if not FField.DataSet.GetFieldData(FField,@FFieldVal) then
FFieldVal := 0;
end;
//--TBooleanFieldVar---------------------------------------------------------
function TBooleanFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
end;
function TBooleanFieldVar.GetFieldType: TExpressionType;
begin
Result := etBoolean;
end;
procedure TBooleanFieldVar.Refresh(Buffer: PChar);
begin
if not FField.DataSet.GetFieldData(FField,@FFieldVal) then
FFieldVal := False;
end;
//--Expression functions-----------------------------------------------------
//These functions are in the unit dbf_parser, but they are forgotten in the interface section
procedure FuncStrIP_EQ(Param: PExpressionRec);
var
arg0len, arg1len: integer;
match: boolean;
str0, str1: string;
begin
with Param^ do
begin
arg1len := StrLen(Args[1]);
if Args[1][0] = '*' then
begin
if Args[1][arg1len-1] = '*' then
begin
str0 := AnsiStrUpper(Args[0]);
str1 := AnsiStrUpper(Args[1]+1);
setlength(str1, arg1len-2);
match := AnsiPos(str0, str1) = 0;
end else begin
arg0len := StrLen(Args[0]);
// at least length without asterisk
match := arg0len >= arg1len - 1;
if match then
match := AnsiStrLIComp(Args[0]+(arg0len-arg1len+1), Args[1]+1, arg1len-1) = 0;
end;
end else
if Args[1][arg1len-1] = '*' then
begin
arg0len := StrLen(Args[0]);
match := arg0len >= arg1len - 1;
if match then
match := AnsiStrLIComp(Args[0], Args[1], arg1len-1) = 0;
end else begin
match := AnsiStrIComp(Args[0], Args[1]) = 0;
end;
Res.MemoryPos^^ := Char(match);
end;
end;
procedure FuncStrP_EQ(Param: PExpressionRec);
var
arg0len, arg1len: integer;
match: boolean;
begin
with Param^ do
begin
arg1len := StrLen(Args[1]);
if Args[1][0] = '*' then
begin
if Args[1][arg1len-1] = '*' then
begin
Args[1][arg1len-1] := #0;
match := AnsiStrPos(Args[0], Args[1]+1) <> nil;
Args[1][arg1len-1] := '*';
end else begin
arg0len := StrLen(Args[0]);
// at least length without asterisk
match := arg0len >= arg1len - 1;
if match then
match := AnsiStrLComp(Args[0]+(arg0len-arg1len+1), Args[1]+1, arg1len-1) = 0;
end;
end else
if Args[1][arg1len-1] = '*' then
begin
arg0len := StrLen(Args[0]);
match := arg0len >= arg1len - 1;
if match then
match := AnsiStrLComp(Args[0], Args[1], arg1len-1) = 0;
end else begin
match := AnsiStrComp(Args[0], Args[1]) = 0;
end;
Res.MemoryPos^^ := Char(match);
end;
end;
//--TBufDatasetParser---------------------------------------------------------------
var
BufWordsSensGeneralList, BufWordsInsensGeneralList: TExpressList;
BufWordsSensPartialList, BufWordsInsensPartialList: TExpressList;
BufWordsSensNoPartialList, BufWordsInsensNoPartialList: TExpressList;
BufWordsGeneralList: TExpressList;
constructor TBufDatasetParser.Create(Adataset: TDataSet);
begin
FDataset := Adataset;
FFieldVarList := TStringList.Create;
FCaseInsensitive := true;
inherited Create;
end;
destructor TBufDatasetParser.Destroy;
begin
ClearExpressions;
inherited;
FreeAndNil(FFieldVarList);
end;
function TBufDatasetParser.GetResultType: TExpressionType;
begin
// if not a real expression, return type ourself
if FIsExpression then
Result := inherited GetResultType
else
Result := FFieldType;
end;
procedure TBufDatasetParser.SetCaseInsensitive(NewInsensitive: Boolean);
begin
if FCaseInsensitive <> NewInsensitive then
begin
// clear and regenerate functions
FCaseInsensitive := NewInsensitive;
FillExpressList;
end;
end;
procedure TBufDatasetParser.SetPartialMatch(NewPartialMatch: boolean);
begin
if FPartialMatch <> NewPartialMatch then
begin
// refill function list
FPartialMatch := NewPartialMatch;
FillExpressList;
end;
end;
procedure TBufDatasetParser.FillExpressList;
var
lExpression: string;
begin
lExpression := FCurrentExpression;
ClearExpressions;
FWordsList.FreeAll;
FWordsList.AddList(BufWordsGeneralList, 0, BufWordsGeneralList.Count - 1);
if FCaseInsensitive then
begin
FWordsList.AddList(BufWordsInsensGeneralList, 0, BufWordsInsensGeneralList.Count - 1);
if FPartialMatch then
begin
FWordsList.AddList(BufWordsInsensPartialList, 0, BufWordsInsensPartialList.Count - 1);
end else begin
FWordsList.AddList(BufWordsInsensNoPartialList, 0, BufWordsInsensNoPartialList.Count - 1);
end;
end else begin
FWordsList.AddList(BufWordsSensGeneralList, 0, BufWordsSensGeneralList.Count - 1);
if FPartialMatch then
begin
FWordsList.AddList(BufWordsSensPartialList, 0, BufWordsSensPartialList.Count - 1);
end else begin
FWordsList.AddList(BufWordsSensNoPartialList, 0, BufWordsSensNoPartialList.Count - 1);
end;
end;
if Length(lExpression) > 0 then
ParseExpression(lExpression);
end;
function TBufDatasetParser.GetVariableInfo(VarName: string): TField;
begin
Result := FDataset.FindField(VarName);
end;
function TBufDatasetParser.CurrentExpression: string;
begin
Result := FCurrentExpression;
end;
procedure TBufDatasetParser.HandleUnknownVariable(VarName: string);
var
FieldInfo: TField;
TempFieldVar: TFieldVar;
begin
// is this variable a fieldname?
FieldInfo := GetVariableInfo(VarName);
if FieldInfo = nil then
raise EDatabaseError.CreateFmt(SErrIndexBasedOnUnkField, [VarName]);
// define field in parser
case FieldInfo.DataType of
ftString:
begin
TempFieldVar := TStringFieldVar.Create(FieldInfo);
TempFieldVar.FExprWord := DefineStringVariableFixedLen(VarName, TempFieldVar.FieldVal, FieldInfo.Size);
end;
ftBoolean:
begin
TempFieldVar := TBooleanFieldVar.Create(FieldInfo);
TempFieldVar.FExprWord := DefineBooleanVariable(VarName, TempFieldVar.FieldVal);
end;
ftFloat:
begin
TempFieldVar := TFloatFieldVar.Create(FieldInfo);
TempFieldVar.FExprWord := DefineFloatVariable(VarName, TempFieldVar.FieldVal);
end;
ftAutoInc, ftInteger, ftSmallInt:
begin
TempFieldVar := TIntegerFieldVar.Create(FieldInfo);
TempFieldVar.FExprWord := DefineIntegerVariable(VarName, TempFieldVar.FieldVal);
end;
ftLargeInt:
begin
TempFieldVar := TLargeIntFieldVar.Create(FieldInfo);
TempFieldVar.FExprWord := DefineLargeIntVariable(VarName, TempFieldVar.FieldVal);
end;
ftDate, ftDateTime:
begin
TempFieldVar := TDateTimeFieldVar.Create(FieldInfo);
TempFieldVar.FExprWord := DefineDateTimeVariable(VarName, TempFieldVar.FieldVal);
end;
else
raise EDatabaseError.CreateFmt(SErrIndexBasedOnInvField, [VarName]);
end;
// add to our own list
FFieldVarList.AddObject(VarName, TempFieldVar);
end;
procedure TBufDatasetParser.ClearExpressions;
var
I: Integer;
begin
inherited;
// test if already freed
if FFieldVarList <> nil then
begin
// free field list
for I := 0 to FFieldVarList.Count - 1 do
begin
// replacing with nil = undefining variable
FWordsList.DoFree(TFieldVar(FFieldVarList.Objects[I]).FExprWord);
TFieldVar(FFieldVarList.Objects[I]).Free;
end;
FFieldVarList.Clear;
end;
// clear expression
FCurrentExpression := EmptyStr;
end;
procedure TBufDatasetParser.ParseExpression(AExpression: string);
var
TempBuffer: pchar;
begin
// clear any current expression
ClearExpressions;
// is this a simple field or complex expression?
FIsExpression := GetVariableInfo(AExpression) = nil;
if FIsExpression then
begin
// parse requested
CompileExpression(AExpression);
// determine length of string length expressions
if ResultType = etString then
begin
// make empty record
GetMem(TempBuffer, FDataset.RecordSize);
try
FillChar(TempBuffer^, FDataset.RecordSize, #0);
FResultLen := StrLen(ExtractFromBuffer(TempBuffer));
finally
FreeMem(TempBuffer);
end;
end;
end else begin
// simple field, create field variable for it
HandleUnknownVariable(AExpression);
FFieldType := TFieldVar(FFieldVarList.Objects[0]).FieldType;
// set result len of variable length fields
if FFieldType = etString then
FResultLen := TFieldVar(FFieldVarList.Objects[0]).FieldDef.Size
end;
// set result len for fixed length expressions / fields
case ResultType of
etBoolean: FResultLen := 1;
etInteger: FResultLen := 4;
etFloat: FResultLen := 8;
etDateTime: FResultLen := 8;
end;
// check if expression not too long
if FResultLen > 100 then
raise EDatabaseError.CreateFmt(SErrIndexResultTooLong, [AExpression, FResultLen]);
// if no errors, assign current expression
FCurrentExpression := AExpression;
end;
function TBufDatasetParser.ExtractFromBuffer(Buffer: PChar): PChar;
var
I: Integer;
begin
// prepare all field variables
for I := 0 to FFieldVarList.Count - 1 do
TFieldVar(FFieldVarList.Objects[I]).Refresh(Buffer);
// complex expression?
if FIsExpression then
begin
// execute expression
EvaluateCurrent;
Result := ExpResult;
end else begin
// simple field, get field result
Result := TFieldVar(FFieldVarList.Objects[0]).FieldVal;
// if string then dereference
if FFieldType = etString then
Result := PPChar(Result)^;
end;
end;
initialization
BufWordsGeneralList := TExpressList.Create;
BufWordsInsensGeneralList := TExpressList.Create;
BufWordsInsensNoPartialList := TExpressList.Create;
BufWordsInsensPartialList := TExpressList.Create;
BufWordsSensGeneralList := TExpressList.Create;
BufWordsSensNoPartialList := TExpressList.Create;
BufWordsSensPartialList := TExpressList.Create;
with BufWordsGeneralList do
begin
// basic function functionality
Add(TLeftBracket.Create('(', nil));
Add(TRightBracket.Create(')', nil));
Add(TComma.Create(',', nil));
// operators - name, param types, result type, func addr, precedence
Add(TFunction.CreateOper('+', 'SS', etString, nil, 40));
Add(TFunction.CreateOper('+', 'FF', etFloat, FuncAdd_F_FF, 40));
Add(TFunction.CreateOper('+', 'FI', etFloat, FuncAdd_F_FI, 40));
Add(TFunction.CreateOper('+', 'IF', etFloat, FuncAdd_F_IF, 40));
Add(TFunction.CreateOper('+', 'II', etInteger, FuncAdd_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('+', 'FL', etFloat, FuncAdd_F_FL, 40));
Add(TFunction.CreateOper('+', 'IL', etLargeInt, FuncAdd_F_IL, 40));
Add(TFunction.CreateOper('+', 'LF', etFloat, FuncAdd_F_LF, 40));
Add(TFunction.CreateOper('+', 'LL', etLargeInt, FuncAdd_F_LI, 40));
Add(TFunction.CreateOper('+', 'LI', etLargeInt, FuncAdd_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('-', 'FF', etFloat, FuncSub_F_FF, 40));
Add(TFunction.CreateOper('-', 'FI', etFloat, FuncSub_F_FI, 40));
Add(TFunction.CreateOper('-', 'IF', etFloat, FuncSub_F_IF, 40));
Add(TFunction.CreateOper('-', 'II', etInteger, FuncSub_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('-', 'FL', etFloat, FuncSub_F_FL, 40));
Add(TFunction.CreateOper('-', 'IL', etLargeInt, FuncSub_F_IL, 40));
Add(TFunction.CreateOper('-', 'LF', etFloat, FuncSub_F_LF, 40));
Add(TFunction.CreateOper('-', 'LL', etLargeInt, FuncSub_F_LI, 40));
Add(TFunction.CreateOper('-', 'LI', etLargeInt, FuncSub_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('*', 'FF', etFloat, FuncMul_F_FF, 40));
Add(TFunction.CreateOper('*', 'FI', etFloat, FuncMul_F_FI, 40));
Add(TFunction.CreateOper('*', 'IF', etFloat, FuncMul_F_IF, 40));
Add(TFunction.CreateOper('*', 'II', etInteger, FuncMul_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('*', 'FL', etFloat, FuncMul_F_FL, 40));
Add(TFunction.CreateOper('*', 'IL', etLargeInt, FuncMul_F_IL, 40));
Add(TFunction.CreateOper('*', 'LF', etFloat, FuncMul_F_LF, 40));
Add(TFunction.CreateOper('*', 'LL', etLargeInt, FuncMul_F_LI, 40));
Add(TFunction.CreateOper('*', 'LI', etLargeInt, FuncMul_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('/', 'FF', etFloat, FuncDiv_F_FF, 40));
Add(TFunction.CreateOper('/', 'FI', etFloat, FuncDiv_F_FI, 40));
Add(TFunction.CreateOper('/', 'IF', etFloat, FuncDiv_F_IF, 40));
Add(TFunction.CreateOper('/', 'II', etInteger, FuncDiv_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('/', 'FL', etFloat, FuncDiv_F_FL, 40));
Add(TFunction.CreateOper('/', 'IL', etLargeInt, FuncDiv_F_IL, 40));
Add(TFunction.CreateOper('/', 'LF', etFloat, FuncDiv_F_LF, 40));
Add(TFunction.CreateOper('/', 'LL', etLargeInt, FuncDiv_F_LI, 40));
Add(TFunction.CreateOper('/', 'LI', etLargeInt, FuncDiv_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('=', 'FF', etBoolean, Func_FF_EQ , 80));
Add(TFunction.CreateOper('<', 'FF', etBoolean, Func_FF_LT , 80));
Add(TFunction.CreateOper('>', 'FF', etBoolean, Func_FF_GT , 80));
Add(TFunction.CreateOper('<=','FF', etBoolean, Func_FF_LTE, 80));
Add(TFunction.CreateOper('>=','FF', etBoolean, Func_FF_GTE, 80));
Add(TFunction.CreateOper('<>','FF', etBoolean, Func_FF_NEQ, 80));
Add(TFunction.CreateOper('=', 'FI', etBoolean, Func_FI_EQ , 80));
Add(TFunction.CreateOper('<', 'FI', etBoolean, Func_FI_LT , 80));
Add(TFunction.CreateOper('>', 'FI', etBoolean, Func_FI_GT , 80));
Add(TFunction.CreateOper('<=','FI', etBoolean, Func_FI_LTE, 80));
Add(TFunction.CreateOper('>=','FI', etBoolean, Func_FI_GTE, 80));
Add(TFunction.CreateOper('<>','FI', etBoolean, Func_FI_NEQ, 80));
Add(TFunction.CreateOper('=', 'II', etBoolean, Func_II_EQ , 80));
Add(TFunction.CreateOper('<', 'II', etBoolean, Func_II_LT , 80));
Add(TFunction.CreateOper('>', 'II', etBoolean, Func_II_GT , 80));
Add(TFunction.CreateOper('<=','II', etBoolean, Func_II_LTE, 80));
Add(TFunction.CreateOper('>=','II', etBoolean, Func_II_GTE, 80));
Add(TFunction.CreateOper('<>','II', etBoolean, Func_II_NEQ, 80));
Add(TFunction.CreateOper('=', 'IF', etBoolean, Func_IF_EQ , 80));
Add(TFunction.CreateOper('<', 'IF', etBoolean, Func_IF_LT , 80));
Add(TFunction.CreateOper('>', 'IF', etBoolean, Func_IF_GT , 80));
Add(TFunction.CreateOper('<=','IF', etBoolean, Func_IF_LTE, 80));
Add(TFunction.CreateOper('>=','IF', etBoolean, Func_IF_GTE, 80));
Add(TFunction.CreateOper('<>','IF', etBoolean, Func_IF_NEQ, 80));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('=', 'LL', etBoolean, Func_LL_EQ , 80));
Add(TFunction.CreateOper('<', 'LL', etBoolean, Func_LL_LT , 80));
Add(TFunction.CreateOper('>', 'LL', etBoolean, Func_LL_GT , 80));
Add(TFunction.CreateOper('<=','LL', etBoolean, Func_LL_LTE, 80));
Add(TFunction.CreateOper('>=','LL', etBoolean, Func_LL_GTE, 80));
Add(TFunction.CreateOper('<>','LL', etBoolean, Func_LL_NEQ, 80));
Add(TFunction.CreateOper('=', 'LF', etBoolean, Func_LF_EQ , 80));
Add(TFunction.CreateOper('<', 'LF', etBoolean, Func_LF_LT , 80));
Add(TFunction.CreateOper('>', 'LF', etBoolean, Func_LF_GT , 80));
Add(TFunction.CreateOper('<=','LF', etBoolean, Func_LF_LTE, 80));
Add(TFunction.CreateOper('>=','LF', etBoolean, Func_LF_GTE, 80));
Add(TFunction.CreateOper('<>','FI', etBoolean, Func_LF_NEQ, 80));
Add(TFunction.CreateOper('=', 'LI', etBoolean, Func_LI_EQ , 80));
Add(TFunction.CreateOper('<', 'LI', etBoolean, Func_LI_LT , 80));
Add(TFunction.CreateOper('>', 'LI', etBoolean, Func_LI_GT , 80));
Add(TFunction.CreateOper('<=','LI', etBoolean, Func_LI_LTE, 80));
Add(TFunction.CreateOper('>=','LI', etBoolean, Func_LI_GTE, 80));
Add(TFunction.CreateOper('<>','LI', etBoolean, Func_LI_NEQ, 80));
Add(TFunction.CreateOper('=', 'FL', etBoolean, Func_FL_EQ , 80));
Add(TFunction.CreateOper('<', 'FL', etBoolean, Func_FL_LT , 80));
Add(TFunction.CreateOper('>', 'FL', etBoolean, Func_FL_GT , 80));
Add(TFunction.CreateOper('<=','FL', etBoolean, Func_FL_LTE, 80));
Add(TFunction.CreateOper('>=','FL', etBoolean, Func_FL_GTE, 80));
Add(TFunction.CreateOper('<>','FL', etBoolean, Func_FL_NEQ, 80));
Add(TFunction.CreateOper('=', 'IL', etBoolean, Func_IL_EQ , 80));
Add(TFunction.CreateOper('<', 'IL', etBoolean, Func_IL_LT , 80));
Add(TFunction.CreateOper('>', 'IL', etBoolean, Func_IL_GT , 80));
Add(TFunction.CreateOper('<=','IL', etBoolean, Func_IL_LTE, 80));
Add(TFunction.CreateOper('>=','IL', etBoolean, Func_IL_GTE, 80));
Add(TFunction.CreateOper('<>','IL', etBoolean, Func_IL_NEQ, 80));
{$endif}
Add(TFunction.CreateOper('NOT', 'B', etBoolean, Func_NOT, 85));
Add(TFunction.CreateOper('AND', 'BB', etBoolean, Func_AND, 90));
Add(TFunction.CreateOper('OR', 'BB', etBoolean, Func_OR, 100));
// Functions - name, description, param types, min params, result type, Func addr
Add(TFunction.Create('STR', '', 'FII', 1, etString, FuncFloatToStr, ''));
Add(TFunction.Create('STR', '', 'III', 1, etString, FuncIntToStr, ''));
Add(TFunction.Create('DTOS', '', 'D', 1, etString, FuncDateToStr, ''));
Add(TFunction.Create('SUBSTR', 'SUBS', 'SII', 3, etString, FuncSubString, ''));
Add(TFunction.Create('UPPERCASE', 'UPPER', 'S', 1, etString, FuncUppercase, ''));
Add(TFunction.Create('LOWERCASE', 'LOWER', 'S', 1, etString, FuncLowercase, ''));
end;
with BufWordsInsensGeneralList do
begin
Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStrI_LT , 80));
Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStrI_GT , 80));
Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStrI_LTE, 80));
Add(TFunction.CreateOper('>=','SS', etBoolean, FuncStrI_GTE, 80));
Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStrI_NEQ, 80));
end;
with BufWordsInsensNoPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrI_EQ , 80));
with BufWordsInsensPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrIP_EQ, 80));
with BufWordsSensGeneralList do
begin
Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStr_LT , 80));
Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStr_GT , 80));
Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStr_LTE, 80));
Add(TFunction.CreateOper('>=','SS', etBoolean, FuncStr_GTE, 80));
Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStr_NEQ, 80));
end;
with BufWordsSensNoPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStr_EQ , 80));
with BufWordsSensPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrP_EQ , 80));
finalization
BufWordsGeneralList.Free;
BufWordsInsensGeneralList.Free;
BufWordsInsensNoPartialList.Free;
BufWordsInsensPartialList.Free;
BufWordsSensGeneralList.Free;
BufWordsSensNoPartialList.Free;
BufWordsSensPartialList.Free;
end.

148
fcl/db/db.pp
View File

@ -69,7 +69,6 @@ type
TField = class;
TFields = Class;
TDataSet = class;
TBufDataSet = class;
TDataBase = Class;
TDatasource = Class;
TDatalink = Class;
@ -924,8 +923,6 @@ type
TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
var DataAction: TDataAction) of object;
TResolverErrorEvent = procedure(Sender: TObject; DataSet: TBufDataset; E: EUpdateError;
UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
TFilterOption = (foCaseInsensitive, foNoPartialCompare);
TFilterOptions = set of TFilterOption;
@ -1102,8 +1099,6 @@ type
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; virtual; abstract;
function GetDataSource: TDataSource; virtual;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; virtual;
function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; virtual;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
function GetRecordSize: Word; virtual; abstract;
procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); virtual; abstract;
@ -1121,12 +1116,14 @@ type
function IsCursorOpen: Boolean; virtual; abstract;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); virtual; abstract;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
procedure SetFieldData(Field: TField; Buffer: Pointer); overload; virtual;
procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function ActiveBuffer: PChar;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; virtual;
function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; virtual;
procedure SetFieldData(Field: TField; Buffer: Pointer); overload; virtual;
procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; virtual;
procedure Append;
procedure AppendRecord(const Values: array of const);
function BookmarkValid(ABookmark: TBookmark): Boolean; virtual;
@ -1498,143 +1495,7 @@ type
property BeforeDisconnect : TNotifyEvent read FBeforeDisconnect write SetBeforeDisconnect;
end;
{ TBufBlobStream }
PBlobBuffer = ^TBlobBuffer;
TBlobBuffer = record
FieldNo : integer;
OrgBufID: integer;
Buffer : pointer;
Size : ptrint;
end;
TBufBlobStream = class(TStream)
private
FBlobBuffer : PBlobBuffer;
FPosition : ptrint;
FDataset : TBufDataset;
protected
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
public
constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
end;
{ TBufDataset }
PBufRecLinkItem = ^TBufRecLinkItem;
TBufRecLinkItem = record
prior : PBufRecLinkItem;
next : PBufRecLinkItem;
end;
PBufBookmark = ^TBufBookmark;
TBufBookmark = record
BookmarkData : PBufRecLinkItem;
BookmarkFlag : TBookmarkFlag;
end;
PRecUpdateBuffer = ^TRecUpdateBuffer;
TRecUpdateBuffer = record
UpdateKind : TUpdateKind;
BookmarkData : pointer;
OldValuesBuffer : pchar;
end;
PBufBlobField = ^TBufBlobField;
TBufBlobField = record
ConnBlobBuffer : array[0..11] of byte; // It's here where the db-specific data is stored
BlobBuffer : PBlobBuffer;
end;
TRecordsUpdateBuffer = array of TRecUpdateBuffer;
TBufDataset = class(TDBDataSet)
private
FCurrentRecBuf : PBufRecLinkItem;
FLastRecBuf : PBufRecLinkItem;
FFirstRecBuf : PBufRecLinkItem;
FFilterBuffer : pchar;
FBRecordCount : integer;
FPacketRecords : integer;
FRecordSize : Integer;
FNullmaskSize : byte;
FOpen : Boolean;
FUpdateBuffer : TRecordsUpdateBuffer;
FCurrentUpdateBuffer : integer;
FFieldBufPositions : array of longint;
FAllPacketsFetched : boolean;
FOnUpdateError : TResolverErrorEvent;
FBlobBuffers : array of PBlobBuffer;
FUpdateBlobBuffers: array of PBlobBuffer;
function GetCurrentBuffer: PChar;
procedure CalcRecordSize;
function LoadBuffer(Buffer : PChar): TGetResult;
function GetFieldSize(FieldDef : TFieldDef) : longint;
function GetRecordUpdateBuffer : boolean;
procedure SetPacketRecords(aValue : integer);
function IntAllocRecordBuffer: PChar;
procedure DoFilterRecord(var Acceptable: Boolean);
protected
function GetNewBlobBuffer : PBlobBuffer;
function GetNewWriteBlobBuffer : PBlobBuffer;
procedure SetRecNo(Value: Longint); override;
function GetRecNo: Longint; override;
function GetChangeCount: integer; virtual;
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
procedure InternalInitRecord(Buffer: PChar); override;
function GetCanModify: Boolean; override;
function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
procedure InternalOpen; override;
procedure InternalClose; override;
function getnextpacket : integer;
function GetRecordSize: Word; override;
procedure InternalPost; override;
procedure InternalCancel; Override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalLast; override;
procedure InternalSetToRecord(Buffer: PChar); override;
procedure InternalGotoBookmark(ABookmark: Pointer); override;
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
function GetFieldData(Field: TField; Buffer: Pointer;
NativeFormat: Boolean): Boolean; override;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
procedure SetFieldData(Field: TField; Buffer: Pointer;
NativeFormat: Boolean); override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
function IsCursorOpen: Boolean; override;
function GetRecordCount: Longint; override;
procedure ApplyRecUpdate(UpdateKind : TUpdateKind); virtual;
procedure SetOnUpdateError(const aValue: TResolverErrorEvent);
{abstracts, must be overidden by descendents}
function Fetch : boolean; virtual; abstract;
function LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean; virtual; abstract;
procedure LoadBlobIntoStream(Field: TField;AStream: TStream); virtual; abstract;
public
constructor Create(AOwner: TComponent); override;
procedure ApplyUpdates; virtual; overload;
procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
procedure CancelUpdates; virtual;
destructor Destroy; override;
function Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean; override;
function UpdateStatus: TUpdateStatus; override;
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
property ChangeCount : Integer read GetChangeCount;
published
property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
end;
{ TParam }
@ -2249,7 +2110,6 @@ end;
{$i fields.inc}
{$i datasource.inc}
{$i database.inc}
{$i bufdataset.inc}
{$i dsparams.inc}
end.

3
fcl/db/dbconst.pp
View File

@ -35,6 +35,9 @@ Resourcestring
SErrNoStatement = 'SQL statement not set';
SErrTransAlreadyActive = 'Transaction already active';
SErrTransactionnSet = 'Transaction not set';
SErrIndexResultTooLong = 'Index result for "%s" too long, >100 characters (%d).';
SErrIndexBasedOnInvField = 'Field "%s" is an invalid field type to base index on.';
SErrIndexBasedOnUnkField = 'Index based on unknown field "%s".';
SErrConnTransactionnSet = 'Transaction of connection not set';
STransNotActive = 'Operation cannot be performed on an inactive transaction';
STransActive = 'Operation cannot be performed on an active transaction';

2
fcl/db/sqldb/interbase/ibconnection.pp
View File

@ -101,7 +101,7 @@ type
implementation
uses strutils;
uses strutils, bufdataset;
type
TTm = packed record

2
fcl/db/sqldb/sqldb.pp
View File

@ -20,7 +20,7 @@ unit sqldb;
interface
uses SysUtils, Classes, DB;
uses SysUtils, Classes, DB, bufdataset;
type TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages);
TConnOption = (sqSupportParams);