summaryrefslogtreecommitdiff
path: root/packages/fcl-db
diff options
context:
space:
mode:
Diffstat (limited to 'packages/fcl-db')
-rw-r--r--packages/fcl-db/src/base/fields.inc25
-rw-r--r--packages/fcl-db/src/memds/memds.pp59
-rw-r--r--packages/fcl-db/src/sqldb/mysql/mysql50conn.pas1
-rw-r--r--packages/fcl-db/src/sqldb/mysql/mysql51conn.pas2
-rw-r--r--packages/fcl-db/src/sqldb/mysql/mysqlconn.inc10
-rw-r--r--packages/fcl-db/src/sqldb/postgres/pqconnection.pp16
-rw-r--r--packages/fcl-db/tests/sqldbtoolsunit.pas10
-rw-r--r--packages/fcl-db/tests/testfieldtypes.pas12
8 files changed, 86 insertions, 49 deletions
diff --git a/packages/fcl-db/src/base/fields.inc b/packages/fcl-db/src/base/fields.inc
index 5b0e8b1b8b..66f5bc7d15 100644
--- a/packages/fcl-db/src/base/fields.inc
+++ b/packages/fcl-db/src/base/fields.inc
@@ -819,7 +819,13 @@ procedure TField.SetData(Buffer: Pointer; NativeFormat : Boolean);
begin
If Not Assigned(FDataset) then
- EDatabaseError.CreateFmt(SNoDataset,[FieldName]);
+ DatabaseErrorFmt(SNoDataset,[FieldName]);
+ if (FieldNo>0) and not (FDataSet.State in [dsSetKey, dsFilter]) then
+ begin
+ if ReadOnly then
+ DatabaseErrorFmt(SReadOnlyField, [DisplayName], Self);
+ Validate(Buffer);
+ end;
FDataSet.SetFieldData(Self,Buffer, NativeFormat);
end;
@@ -1070,7 +1076,7 @@ function TStringField.GetDataSize: Integer;
begin
if DataType=ftFixedChar then
- Result:=Size
+ Result:=Size+1
else
Result:=Size+1;
end;
@@ -2475,28 +2481,23 @@ end;
procedure TFMTBCDField.GetText(var TheText: string; ADisplayText: Boolean);
var
bcd: TBCD;
- E: double; //remove when formatBCD,BCDToStrF in fmtbcd.pp will be implemented
fmt: String;
begin
if GetData(@bcd) then begin
- E:=BCDToDouble(bcd);
if aDisplayText or (FEditFormat='') then
fmt := FDisplayFormat
else
fmt := FEditFormat;
if fmt<>'' then
- TheText := FormatFloat(fmt,E)
- //TheText := FormatBCD(fmt,bcd)
+ TheText := BCDToStr(bcd)
+ //TheText := FormatBCD(fmt,bcd) //uncomment when formatBCD in fmtbcd.pp will be implemented
else if fCurrency then begin
if aDisplayText then
- TheText := FloatToStrF(E, ffCurrency, FPrecision, 2{digits?})
- //TheText := BcdToStrF(bcd, ffCurrency, FPrecision, 2{digits?})
+ TheText := BcdToStrF(bcd, ffCurrency, FPrecision, 2)
else
- TheText := FloatToStrF(E, ffFixed, FPrecision, 2{digits?});
- //TheText := BcdToStrF(bcd, ffFixed, FPrecision, 2{digits?});
+ TheText := BcdToStrF(bcd, ffFixed, FPrecision, 2);
end else
- TheText := BcdToStr(bcd);
- //TheText := BcdToStrF(bcd, ffGeneral, FPrecision, FSize);
+ TheText := BcdToStrF(bcd, ffGeneral, FPrecision, FSize);
end else
TheText := '';
end;
diff --git a/packages/fcl-db/src/memds/memds.pp b/packages/fcl-db/src/memds/memds.pp
index d109fd4547..f7807f68d0 100644
--- a/packages/fcl-db/src/memds/memds.pp
+++ b/packages/fcl-db/src/memds/memds.pp
@@ -11,8 +11,10 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
+{$IFDEF FPC}
{$mode objfpc}
{$H+}
+{$ENDIF}
{
TMemDataset : In-memory dataset.
- Has possibility to copy Structure/Data from other dataset.
@@ -37,6 +39,10 @@ const
smData = 2;
type
+ {$IFNDEF FPC}
+ ptrint = Integer;
+ {$ENDIF}
+
MDSError=class(Exception);
PRecInfo=^TMTRecInfo;
@@ -63,6 +69,9 @@ type
FFilterBuffer: PChar;
ffieldoffsets: PInteger;
ffieldsizes: PInteger;
+ function GetCharPointer(p:PChar; Pos:Integer):PChar;
+ function GetIntegerPointer(p:PInteger; Pos:Integer):PInteger;
+
procedure calcrecordlayout;
function MDSGetRecordOffset(ARecNo: integer): longint;
function MDSGetFieldOffset(FieldNo: integer): integer;
@@ -123,16 +132,16 @@ type
Function DataSize : Integer;
- procedure Clear(ClearDefs : Boolean);
- procedure Clear;
- Procedure SaveToFile(AFileName : String);
- Procedure SaveToFile(AFileName : String; SaveData : Boolean);
- Procedure SaveToStream(F : TStream);
- Procedure SaveToStream(F : TStream; SaveData : Boolean);
+ procedure Clear(ClearDefs : Boolean);{$IFNDEF FPC} overload; {$ENDIF}
+ procedure Clear;{$IFNDEF FPC} overload; {$ENDIF}
+ Procedure SaveToFile(AFileName : String);{$IFNDEF FPC} overload; {$ENDIF}
+ Procedure SaveToFile(AFileName : String; SaveData : Boolean);{$IFNDEF FPC} overload; {$ENDIF}
+ Procedure SaveToStream(F : TStream); {$IFNDEF FPC} overload; {$ENDIF}
+ Procedure SaveToStream(F : TStream; SaveData : Boolean);{$IFNDEF FPC} overload; {$ENDIF}
Procedure LoadFromStream(F : TStream);
Procedure LoadFromFile(AFileName : String);
- Procedure CopyFromDataset(DataSet : TDataSet);
- Procedure CopyFromDataset(DataSet : TDataSet; CopyData : Boolean);
+ Procedure CopyFromDataset(DataSet : TDataSet); {$IFNDEF FPC} overload; {$ENDIF}
+ Procedure CopyFromDataset(DataSet : TDataSet; CopyData : Boolean); {$IFNDEF FPC} overload; {$ENDIF}
Property FileModified : Boolean Read FFileModified;
@@ -284,7 +293,7 @@ end;
function TMemDataset.MDSGetFieldOffset(FieldNo: integer): integer;
begin
- result:= ffieldoffsets[fieldno-1];
+ result:= getIntegerpointer(ffieldoffsets, fieldno-1)^;
end;
Procedure TMemDataset.RaiseError(Fmt : String; Args : Array of const);
@@ -300,6 +309,7 @@ begin
dt1:= FieldDefs.Items[FieldNo-1].Datatype;
case dt1 of
ftString: result:=FieldDefs.Items[FieldNo-1].Size+1;
+ ftFixedChar:result:=FieldDefs.Items[FieldNo-1].Size+1;
ftBoolean: result:=SizeOf(Wordbool);
ftFloat: result:=SizeOf(Double);
ftLargeInt: result:=SizeOf(int64);
@@ -705,7 +715,7 @@ begin
not getfieldisnull(pointer(srcbuffer),I);
if result and (buffer <> nil) then
begin
- Move((SrcBuffer+ffieldoffsets[I])^, Buffer^,FFieldSizes[I]);
+ Move(getcharpointer(SrcBuffer,getintegerpointer(ffieldoffsets,I)^)^, Buffer^,GetIntegerPointer(FFieldSizes, I)^);
end;
end;
@@ -723,10 +733,10 @@ begin
else
begin
unsetfieldisnull(pointer(destbuffer),I);
- J:=FFieldSizes[I];
+ J:=GetIntegerPointer(FFieldSizes, I)^;
if Field.DataType=ftString then
Dec(J); // Do not move terminating 0, which is in the size.
- Move(Buffer^,(DestBuffer+FFieldOffsets[I])^,J);
+ Move(Buffer^,GetCharPointer(DestBuffer, getIntegerPointer(FFieldOffsets, I)^)^,J);
dataevent(defieldchange,ptrint(field));
end;
end;
@@ -842,18 +852,22 @@ begin
// Avoid mem-leak if CreateTable is called twice
FreeMem(ffieldoffsets);
Freemem(ffieldsizes);
-
+ {$IFDEF FPC}
FFieldOffsets:=getmem(Count*sizeof(integer));
FFieldSizes:=getmem(Count*sizeof(integer));
+ {$ELSE}
+ getmem(FFieldOffsets, Count*sizeof(integer));
+ getmem(FFieldSizes, Count*sizeof(integer));
+ {$ENDIF}
FRecSize:= (Count+7) div 8; //null mask
{$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
FRecSize:=Align(FRecSize,4);
{$ENDIF}
for i:= 0 to Count-1 do
begin
- ffieldoffsets[i] := frecsize;
- ffieldsizes[i] := MDSGetbufferSize(i+1);
- FRecSize:= FRecSize+FFieldSizes[i];
+ GetIntegerPointer(ffieldoffsets, i)^ := frecsize;
+ GetIntegerPointer(ffieldsizes, i)^ := MDSGetbufferSize(i+1);
+ FRecSize:= FRecSize+GetIntegerPointeR(FFieldSizes, i)^;
end;
end;
@@ -964,6 +978,7 @@ begin
ftInteger : F1.AsInteger:=F2.AsInteger;
ftDate : F1.AsDateTime:=F2.AsDateTime;
ftTime : F1.AsDateTime:=F2.AsDateTime;
+ ftDateTime : F1.AsDateTime:=F2.AsDateTime;
end;
end;
Try
@@ -986,4 +1001,16 @@ begin
end;
end;
+function TMemDataset.GetCharPointer(p:PChar; Pos:Integer):PChar;
+begin
+ Result:=p;
+ inc(Result, Pos);
+end;
+
+function TMemDataset.GetIntegerPointer(p:PInteger; Pos:Integer):PInteger;
+begin
+ Result:=p;
+ inc(Result, Pos);
+end;
+
end.
diff --git a/packages/fcl-db/src/sqldb/mysql/mysql50conn.pas b/packages/fcl-db/src/sqldb/mysql/mysql50conn.pas
index a3695ad929..80e3994d91 100644
--- a/packages/fcl-db/src/sqldb/mysql/mysql50conn.pas
+++ b/packages/fcl-db/src/sqldb/mysql/mysql50conn.pas
@@ -4,6 +4,7 @@
unit mysql50conn;
+{$DEFINE MYSQL50_up}
{$DEFINE MYSQL50}
{$i mysqlconn.inc}
diff --git a/packages/fcl-db/src/sqldb/mysql/mysql51conn.pas b/packages/fcl-db/src/sqldb/mysql/mysql51conn.pas
index 9088bc80f4..41bbc113b0 100644
--- a/packages/fcl-db/src/sqldb/mysql/mysql51conn.pas
+++ b/packages/fcl-db/src/sqldb/mysql/mysql51conn.pas
@@ -4,6 +4,8 @@
unit mysql51conn;
+{$DEFINE MYSQL50_UP}
+{$DEFINE MYSQL51_UP}
{$DEFINE MYSQL51}
{$i mysqlconn.inc}
diff --git a/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc b/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc
index 0ed85ff45c..8f6f7a61e2 100644
--- a/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc
+++ b/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc
@@ -188,12 +188,8 @@ const
'MYSQL_OPT_USE_REMOTE_CONNECTION','MYSQL_OPT_USE_EMBEDDED_CONNECTION',
'MYSQL_OPT_GUESS_CONNECTION','MYSQL_SET_CLIENT_IP',
'MYSQL_SECURE_AUTH'
-{$IFDEF MYSQL50}
+{$IFDEF MYSQL50_UP}
,'MYSQL_REPORT_DATA_TRUNCATION', 'MYSQL_OPT_RECONNECT'
-{$ELSE}
- {$IFDEF MYSQL51}
- ,'MYSQL_REPORT_DATA_TRUNCATION', 'MYSQL_OPT_RECONNECT'
- {$ENDIF}
{$ENDIF}
);
@@ -559,7 +555,7 @@ begin
NewType := ftInteger;
NewSize := 0;
end;
-{$ifdef mysql50}
+{$ifdef mysql50_up}
FIELD_TYPE_NEWDECIMAL,
{$endif}
FIELD_TYPE_DECIMAL: if ADecimals < 5 then
@@ -867,7 +863,7 @@ begin
VL := 0;
Move(VL, Dest^, SizeOf(LargeInt));
end;
-{$ifdef mysql50}
+{$ifdef mysql50_up}
FIELD_TYPE_NEWDECIMAL,
{$endif}
FIELD_TYPE_DECIMAL, FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE:
diff --git a/packages/fcl-db/src/sqldb/postgres/pqconnection.pp b/packages/fcl-db/src/sqldb/postgres/pqconnection.pp
index 664b8a2bd9..d40e9a9398 100644
--- a/packages/fcl-db/src/sqldb/postgres/pqconnection.pp
+++ b/packages/fcl-db/src/sqldb/postgres/pqconnection.pp
@@ -546,7 +546,7 @@ begin
FPrepared := True;
end
else
- statement := buf;
+ statement := AParams.ParseSQL(buf,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psPostgreSQL);
end;
end;
@@ -561,10 +561,11 @@ begin
res := pqexec(tr.PGConn,pchar('deallocate prepst'+nr));
if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
begin
+ pqclear(res);
+ DatabaseError(SErrPrepareFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self)
+ end
+ else
pqclear(res);
- DatabaseError(SErrPrepareFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self)
- end;
- pqclear(res);
end;
FPrepared := False;
end;
@@ -641,9 +642,12 @@ begin
s := Statement;
res := pqexec(tr.PGConn,pchar(s));
if (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
- pqclear(res);
+ begin
+ pqclear(res);
+ res:=nil;
+ end;
end;
- if not (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
+ if assigned(res) and not (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
begin
s := PQerrorMessage(tr.PGConn);
pqclear(res);
diff --git a/packages/fcl-db/tests/sqldbtoolsunit.pas b/packages/fcl-db/tests/sqldbtoolsunit.pas
index 0c4482fbd2..60d9893ca2 100644
--- a/packages/fcl-db/tests/sqldbtoolsunit.pas
+++ b/packages/fcl-db/tests/sqldbtoolsunit.pas
@@ -7,13 +7,13 @@ interface
uses
Classes, SysUtils, toolsunit,
db,
- sqldb, ibconnection, mysql40conn, mysql41conn, mysql50conn, pqconnection,odbcconn,oracleconnection,sqlite3conn;
+ sqldb, ibconnection, mysql40conn, mysql41conn, mysql50conn, mysql51conn, pqconnection,odbcconn,oracleconnection,sqlite3conn;
-type TSQLDBTypes = (mysql40,mysql41,mysql50,postgresql,interbase,odbc,oracle,sqlite3);
+type TSQLDBTypes = (mysql40,mysql41,mysql50,mysql51,postgresql,interbase,odbc,oracle,sqlite3);
const MySQLdbTypes = [mysql40,mysql41,mysql50];
DBTypesNames : Array [TSQLDBTypes] of String[19] =
- ('MYSQL40','MYSQL41','MYSQL50','POSTGRESQL','INTERBASE','ODBC','ORACLE','SQLITE3');
+ ('MYSQL40','MYSQL41','MYSQL50','MYSQL51','POSTGRESQL','INTERBASE','ODBC','ORACLE','SQLITE3');
FieldtypeDefinitionsConst : Array [TFieldType] of String[15] =
(
@@ -115,8 +115,7 @@ begin
testStringValues[t] := TrimRight(testStringValues[t]);
end;
if SQLDbType = MYSQL50 then Fconnection := tMySQL50Connection.Create(nil);
- if SQLDbType in MySQLdbTypes then
- FieldtypeDefinitions[ftLargeint] := 'BIGINT';
+ if SQLDbType = MYSQL51 then Fconnection := tMySQL51Connection.Create(nil);
if SQLDbType = sqlite3 then
begin
Fconnection := TSQLite3Connection.Create(nil);
@@ -134,7 +133,6 @@ begin
if SQLDbType = INTERBASE then
begin
Fconnection := tIBConnection.Create(nil);
- FieldtypeDefinitions[ftLargeint] := 'BIGINT';
end;
if SQLDbType = ODBC then Fconnection := tODBCConnection.Create(nil);
if SQLDbType = ORACLE then Fconnection := TOracleConnection.Create(nil);
diff --git a/packages/fcl-db/tests/testfieldtypes.pas b/packages/fcl-db/tests/testfieldtypes.pas
index 0925465ce8..67b634a76a 100644
--- a/packages/fcl-db/tests/testfieldtypes.pas
+++ b/packages/fcl-db/tests/testfieldtypes.pas
@@ -1391,7 +1391,10 @@ begin
begin
with query do
begin
- SQL.Text:='select NAME from FPDEV where NAME=''TestName21'' limit 1';
+ if (sqlDBtype=interbase) then
+ SQL.Text:='select first 1 NAME from FPDEV where NAME=''TestName21'''
+ else
+ SQL.Text:='select NAME from FPDEV where NAME=''TestName21'' limit 1';
Open;
close;
ServerFilter:='ID=21';
@@ -1626,6 +1629,8 @@ procedure TTestFieldTypes.TestSQLClob;
AssertEquals(testStringValues[a],AField.AsString);
end;
begin
+ if SQLDbType=interbase then
+ Ignore('This test does not apply to Interbase/Firebird, since it does not support CLOB fields');
TestSQLFieldType(ftMemo, 'CLOB', 0, @TestSQLClob_GetSQLText, @CheckFieldValue);
end;
@@ -1641,7 +1646,10 @@ procedure TTestFieldTypes.TestSQLLargeint;
AssertEquals(testLargeIntValues[a],AField.AsLargeInt);
end;
begin
- TestSQLFieldType(ftLargeint, 'LARGEINT', 8, @TestSQLLargeint_GetSQLText, @CheckFieldValue);
+ if sqlDBType=interbase then
+ TestSQLFieldType(ftLargeint, 'BIGINT', 8, @TestSQLLargeint_GetSQLText, @CheckFieldValue)
+ else
+ TestSQLFieldType(ftLargeint, 'LARGEINT', 8, @TestSQLLargeint_GetSQLText, @CheckFieldValue);
end;
View Lorry Controller Status