123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822 |
- {$mode objfpc}{$H+}
- {$MACRO on}
- interface
- uses
- Classes, SysUtils,sqldb,db,dynlibs,
- {$IfDef mysql50}
- mysql50dyn;
- {$DEFINE TConnectionName:=TMySQL50Connection}
- {$DEFINE TTransactionName:=TMySQL50Transaction}
- {$DEFINE TCursorName:=TMySQL50Cursor}
- {$ELSE}
- {$IfDef mysql41}
- mysql41dyn;
- {$DEFINE TConnectionName:=TMySQL41Connection}
- {$DEFINE TTransactionName:=TMySQL41Transaction}
- {$DEFINE TCursorName:=TMySQL41Cursor}
- {$ELSE}
- {$IFDEF mysql4} // temporary backwards compatibility for Lazarus
- mysql40dyn;
- {$DEFINE TConnectionName:=TMySQLConnection}
- {$DEFINE TTransactionName:=TMySQLTransaction}
- {$DEFINE TCursorName:=TMySQLCursor}
- {$ELSE}
- mysql40dyn;
- {$DEFINE TConnectionName:=TMySQL40Connection}
- {$DEFINE TTransactionName:=TMySQL40Transaction}
- {$DEFINE TCursorName:=TMySQL40Cursor}
- {$EndIf}
- {$EndIf}
- {$EndIf}
- Type
- TTransactionName = Class(TSQLHandle)
- protected
- end;
- { TCursorName }
- TCursorName = Class(TSQLCursor)
- protected
- FQMySQL : PMySQL;
- FRes: PMYSQL_RES; { Record pointer }
- FNeedData : Boolean;
- FStatement : String;
- Row : MYSQL_ROW;
- RowsAffected : QWord;
- LastInsertID : QWord;
- ParamBinding : TParamBinding;
- ParamReplaceString : String;
- MapDSRowToMSQLRow : array of integer;
- FBlobStrings:TStringList; // list of strings in which the blob-fields are stored
- public
- constructor Create;
- destructor Destroy; override;
- end;
- TConnectionName = class (TSQLConnection)
- private
- FDialect: integer;
- FHostInfo: String;
- FServerInfo: String;
- FMySQL : PMySQL;
- FDidConnect : Boolean;
- function GetClientInfo: string;
- function GetServerStatus: String;
- procedure ConnectMySQL(var HMySQL : PMySQL;H,U,P : pchar);
- protected
- function StrToStatementType(s : string) : TStatementType; override;
- Procedure ConnectToServer; virtual;
- Procedure SelectDatabase; virtual;
- function MySQLDataType(AType: enum_field_types; ASize, ADecimals: Integer; var NewType: TFieldType; var NewSize: Integer): Boolean;
- function MySQLWriteData(AType: enum_field_types;ASize: Integer; AFieldType: TFieldType; BlobStrings: TStringList ;Source, Dest: PChar): Boolean;
- // SQLConnection methods
- procedure DoInternalConnect; override;
- procedure DoInternalDisconnect; override;
- function GetHandle : pointer; override;
- function GetAsSQLText(Field : TField) : string; overload; virtual;
- function GetAsSQLText(Param : TParam) : string; overload; virtual;
- Function AllocateCursorHandle : TSQLCursor; override;
- Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
- Function AllocateTransactionHandle : TSQLHandle; override;
- procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
- procedure UnPrepareStatement(cursor:TSQLCursor); override;
- procedure FreeFldBuffers(cursor : TSQLCursor); override;
- procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction;AParams : TParams); override;
- procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); override;
- function Fetch(cursor : TSQLCursor) : boolean; override;
- function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer) : boolean; override;
- function GetTransactionHandle(trans : TSQLHandle): pointer; override;
- function Commit(trans : TSQLHandle) : boolean; override;
- function RollBack(trans : TSQLHandle) : boolean; override;
- function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
- procedure CommitRetaining(trans : TSQLHandle); override;
- procedure RollBackRetaining(trans : TSQLHandle); override;
- procedure UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string); override;
- procedure LoadBlobIntoStream(Field: TField;AStream: TMemoryStream;cursor: TSQLCursor;ATransaction : TSQLTransaction); override;
- Public
- Property ServerInfo : String Read FServerInfo;
- Property HostInfo : String Read FHostInfo;
- property ClientInfo: string read GetClientInfo;
- property ServerStatus : String read GetServerStatus;
- published
- property Dialect : integer read FDialect write FDialect;
- property DatabaseName;
- property HostName;
- property KeepConnection;
- property LoginPrompt;
- property Params;
- property OnLogin;
- end;
- EMySQLError = Class(Exception);
- implementation
- uses dbconst;
- { TConnectionName }
- Resourcestring
- SErrServerConnectFailed = 'Server connect failed.';
- SErrDatabaseSelectFailed = 'failed to select database: %s';
- SErrDatabaseCreate = 'Failed to create database: %s';
- SErrDatabaseDrop = 'Failed to drop database: %s';
- SErrNoData = 'No data for record';
- SErrExecuting = 'Error executing query: %s';
- SErrFetchingdata = 'Error fetching row data: %s';
- SErrGettingResult = 'Error getting result set: %s';
- SErrNoQueryResult = 'No result from query.';
- SErrNotversion50 = 'TMySQL50Connection can not work with the installed MySQL client version (%s).';
- SErrNotversion41 = 'TMySQL41Connection can not work with the installed MySQL client version (%s).';
- SErrNotversion40 = 'TMySQL40Connection can not work with the installed MySQL client version (%s).';
- Procedure MySQlError(R : PMySQL;Msg: String;Comp : TComponent);
- Var
- MySQLMsg : String;
- begin
- If (R<>Nil) then
- begin
- MySQLMsg:=Strpas(mysql_error(R));
- DatabaseErrorFmt(Msg,[MySQLMsg],Comp);
- end
- else
- DatabaseError(Msg,Comp);
- end;
- function TConnectionName.StrToStatementType(s : string) : TStatementType;
- begin
- S:=Lowercase(s);
- if s = 'show' then exit(stSelect);
- result := inherited StrToStatementType(s);
- end;
- function TConnectionName.GetClientInfo: string;
- Var
- B : Boolean;
- begin
- // To make it possible to call this if there's no connection yet
- B:=(MysqlLibraryHandle=Nilhandle);
- If B then
- InitialiseMysql;
- Try
- Result:=strpas(mysql_get_client_info());
- Finally
- if B then
- ReleaseMysql;
- end;
- end;
- function TConnectionName.GetServerStatus: String;
- begin
- CheckConnected;
- Result := mysql_stat(FMYSQL);
- end;
- procedure TConnectionName.ConnectMySQL(var HMySQL : PMySQL;H,U,P : pchar);
- begin
- HMySQL := mysql_init(HMySQL);
- HMySQL:=mysql_real_connect(HMySQL,PChar(H),PChar(U),Pchar(P),Nil,0,Nil,0);
- If (HMySQL=Nil) then
- MySQlError(Nil,SErrServerConnectFailed,Self);
- end;
- function TConnectionName.GetAsSQLText(Field : TField) : string;
- var esc_str : pchar;
- begin
- if (not assigned(field)) or field.IsNull then Result := 'Null'
- else if field.DataType = ftString then
- begin
- Getmem(esc_str,sizeof(field.asstring)*2+1);
- mysql_real_escape_string(FMySQL,esc_str,pchar(field.asstring),length(field.asstring));
- Result := '''' + esc_str + '''';
- Freemem(esc_str);
- end
- else Result := inherited GetAsSqlText(field);
- end;
- function TConnectionName.GetAsSQLText(Param: TParam) : string;
- var esc_str : pchar;
- begin
- if (not assigned(param)) or param.IsNull then Result := 'Null'
- else if param.DataType = ftString then
- begin
- Getmem(esc_str,sizeof(param.asstring)*2+1);
- mysql_real_escape_string(FMySQL,esc_str,pchar(param.asstring),length(param.asstring));
- Result := '''' + esc_str + '''';
- Freemem(esc_str);
- end
- else Result := inherited GetAsSqlText(Param);
- end;
- procedure TConnectionName.ConnectToServer;
- Var
- H,U,P : String;
- begin
- H:=HostName;
- U:=UserName;
- P:=Password;
- ConnectMySQL(FMySQL,pchar(H),pchar(U),pchar(P));
- FServerInfo := strpas(mysql_get_server_info(FMYSQL));
- FHostInfo := strpas(mysql_get_host_info(FMYSQL));
- end;
- procedure TConnectionName.SelectDatabase;
- begin
- if mysql_select_db(FMySQL,pchar(DatabaseName))<>0 then
- MySQLError(FMySQL,SErrDatabaseSelectFailed,Self);
- end;
- procedure TConnectionName.DoInternalConnect;
- begin
- FDidConnect:=(MySQLLibraryHandle=NilHandle);
- if FDidConnect then
- InitialiseMysql;
- {$IFDEF mysql50}
- if copy(strpas(mysql_get_client_info()),1,3)<>'5.0' then
- Raise EInOutError.CreateFmt(SErrNotversion50,[strpas(mysql_get_client_info())]);
- {$ELSE}
- {$IFDEF mysql41}
- if copy(strpas(mysql_get_client_info()),1,3)<>'4.1' then
- Raise EInOutError.CreateFmt(SErrNotversion41,[strpas(mysql_get_client_info())]);
- {$ELSE}
- if copy(strpas(mysql_get_client_info()),1,3)<>'4.0' then
- Raise EInOutError.CreateFmt(SErrNotversion40,[strpas(mysql_get_client_info())]);
- {$ENDIF}
- {$ENDIF}
- inherited DoInternalConnect;
- ConnectToServer;
- SelectDatabase;
- end;
- procedure TConnectionName.DoInternalDisconnect;
- begin
- inherited DoInternalDisconnect;
- mysql_close(FMySQL);
- FMySQL:=Nil;
- if FDidConnect then
- ReleaseMysql;
- end;
- function TConnectionName.GetHandle: pointer;
- begin
- Result:=FMySQL;
- end;
- function TConnectionName.AllocateCursorHandle: TSQLCursor;
- begin
- Result:=TCursorName.Create;
- end;
- Procedure TConnectionName.DeAllocateCursorHandle(var cursor : TSQLCursor);
- begin
- FreeAndNil(cursor);
- end;
- function TConnectionName.AllocateTransactionHandle: TSQLHandle;
- begin
- // Result:=TTransactionName.Create;
- Result := nil;
- end;
- procedure TConnectionName.PrepareStatement(cursor: TSQLCursor;
- ATransaction: TSQLTransaction; buf: string;AParams : TParams);
- begin
- // if assigned(AParams) and (AParams.count > 0) then
- // DatabaseError('Parameters (not) yet supported for the MySQL SqlDB connection.',self);
- With Cursor as TCursorName do
- begin
- FStatement:=Buf;
- if assigned(AParams) and (AParams.count > 0) then
- FStatement := AParams.ParseSQL(FStatement,false,psSimulated,paramBinding,ParamReplaceString);
- if FStatementType=stSelect then
- FNeedData:=True;
- ConnectMySQL(FQMySQL,FMySQL^.host,FMySQL^.user,FMySQL^.passwd);
- if mysql_select_db(FQMySQL,pchar(DatabaseName))<>0 then
- MySQLError(FQMySQL,SErrDatabaseSelectFailed,Self);
- end
- end;
- procedure TConnectionName.UnPrepareStatement(cursor: TSQLCursor);
- begin
- With Cursor as TCursorName do
- begin
- mysql_close(FQMySQL);
- FQMysql := nil;
- end;
- end;
- procedure TConnectionName.FreeFldBuffers(cursor: TSQLCursor);
- Var
- C : TCursorName;
- begin
- C:=Cursor as TCursorName;
- if c.FStatementType=stSelect then
- c.FNeedData:=False;
- if (c.FQMySQL <> Nil) then
- begin
- mysql_close(c.FQMySQL);
- c.FQMySQL:=Nil;
- end;
- If (C.FRes<>Nil) then
- begin
- Mysql_free_result(C.FRes);
- C.FRes:=Nil;
- end;
- SetLength(c.MapDSRowToMSQLRow,0);
- c.FBlobStrings.Clear;
- end;
- procedure TConnectionName.Execute(cursor: TSQLCursor;
- atransaction: tSQLtransaction;AParams : TParams);
- Var
- C : TCursorName;
- i : integer;
- begin
- C:=Cursor as TCursorName;
- If (C.FRes=Nil) then
- begin
- if Assigned(AParams) and (AParams.count > 0) then
- for i := 0 to AParams.count -1 do
- C.FStatement := stringreplace(C.FStatement,C.ParamReplaceString+inttostr(AParams[i].Index+1),GetAsSQLText(AParams[i]),[rfReplaceAll,rfIgnoreCase]);
- if mysql_query(c.FQMySQL,Pchar(C.FStatement))<>0 then
- MySQLError(c.FQMYSQL,Format(SErrExecuting,[StrPas(mysql_error(c.FQMySQL))]),Self)
- else
- begin
- C.RowsAffected := mysql_affected_rows(c.FQMYSQL);
- C.LastInsertID := mysql_insert_id(c.FQMYSQL);
- if C.FNeedData then
- C.FRes:=mysql_use_result(c.FQMySQL);
- end;
- end;
- end;
- function TConnectionName.MySQLDataType(AType: enum_field_types; ASize, ADecimals: Integer;
- var NewType: TFieldType; var NewSize: Integer): Boolean;
- begin
- Result := True;
- case AType of
- FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_LONG, FIELD_TYPE_LONGLONG,
- FIELD_TYPE_INT24:
- begin
- NewType := ftInteger;
- NewSize := 0;
- end;
- {$ifdef mysql50}
- FIELD_TYPE_NEWDECIMAL,
- {$endif}
- FIELD_TYPE_DECIMAL: if ADecimals < 5 then
- begin
- NewType := ftBCD;
- NewSize := 0;
- end
- else
- begin
- NewType := ftFloat;
- NewSize := 0;
- end;
- FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE:
- begin
- NewType := ftFloat;
- NewSize := 0;
- end;
- FIELD_TYPE_TIMESTAMP, FIELD_TYPE_DATETIME:
- begin
- NewType := ftDateTime;
- NewSize := 0;
- end;
- FIELD_TYPE_DATE:
- begin
- NewType := ftDate;
- NewSize := 0;
- end;
- FIELD_TYPE_TIME:
- begin
- NewType := ftTime;
- NewSize := 0;
- end;
- FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET:
- begin
- NewType := ftString;
- NewSize := ASize;
- end;
- FIELD_TYPE_BLOB:
- begin
- NewType := ftBlob;
- NewSize := 0;
- end
- else
- Result := False;
- end;
- end;
- procedure TConnectionName.AddFieldDefs(cursor: TSQLCursor;
- FieldDefs: TfieldDefs);
- var
- C : TCursorName;
- I, TF, FC: Integer;
- field: PMYSQL_FIELD;
- DFT: TFieldType;
- DFS: Integer;
- begin
- // Writeln('MySQL: Adding fielddefs');
- C:=(Cursor as TCursorName);
- If (C.FRes=Nil) then
- begin
- // Writeln('res is nil');
- MySQLError(c.FQMySQL,SErrNoQueryResult,Self);
- end;
- // Writeln('MySQL: have result');
- FC:=mysql_num_fields(C.FRes);
- SetLength(c.MapDSRowToMSQLRow,FC);
- TF := 1;
- For I:= 0 to FC-1 do
- begin
- field := mysql_fetch_field_direct(C.FRES, I);
- // Writeln('MySQL: creating fielddef ',I+1);
- if MySQLDataType(field^.ftype, field^.length, field^.decimals, DFT, DFS) then
- begin
- TFieldDef.Create(FieldDefs, field^.name, DFT, DFS, False, TF);
- c.MapDSRowToMSQLRow[TF-1] := I;
- inc(TF);
- end
- end;
- // Writeln('MySQL: Finished adding fielddefs');
- end;
- function TConnectionName.Fetch(cursor: TSQLCursor): boolean;
- Var
- C : TCursorName;
- begin
- C:=Cursor as TCursorName;
- C.Row:=MySQL_Fetch_row(C.FRes);
- Result:=(C.Row<>Nil);
- end;
- function TConnectionName.LoadField(cursor : TSQLCursor;
- FieldDef : TfieldDef;buffer : pointer) : boolean;
- var
- field: PMYSQL_FIELD;
- row : MYSQL_ROW;
- C : TCursorName;
- begin
- // Writeln('LoadFieldsFromBuffer');
- C:=Cursor as TCursorName;
- if C.Row=nil then
- begin
- // Writeln('LoadFieldsFromBuffer: row=nil');
- MySQLError(c.FQMySQL,SErrFetchingData,Self);
- end;
- Row:=C.Row;
-
- inc(Row,c.MapDSRowToMSQLRow[FieldDef.FieldNo-1]);
- field := mysql_fetch_field_direct(C.FRES, c.MapDSRowToMSQLRow[FieldDef.FieldNo-1]);
- Result := MySQLWriteData(field^.ftype, field^.length, FieldDef.DataType, c.FBlobStrings, Row^, Buffer);
- end;
- function InternalStrToFloat(S: string): Extended;
- var
- I: Integer;
- Tmp: string;
- begin
- Tmp := '';
- for I := 1 to Length(S) do
- begin
- if not (S[I] in ['0'..'9', '+', '-', 'E', 'e']) then
- Tmp := Tmp + DecimalSeparator
- else
- Tmp := Tmp + S[I];
- end;
- Result := StrToFloat(Tmp);
- end;
- function InternalStrToCurrency(S: string): Extended;
- var
- I: Integer;
- Tmp: string;
- begin
- Tmp := '';
- for I := 1 to Length(S) do
- begin
- if not (S[I] in ['0'..'9', '+', '-', 'E', 'e']) then
- Tmp := Tmp + DecimalSeparator
- else
- Tmp := Tmp + S[I];
- end;
- Result := StrToCurr(Tmp);
- end;
- function InternalStrToDate(S: string): TDateTime;
- var
- EY, EM, ED: Word;
- begin
- EY := StrToInt(Copy(S,1,4));
- EM := StrToInt(Copy(S,6,2));
- ED := StrToInt(Copy(S,9,2));
- if (EY = 0) or (EM = 0) or (ED = 0) then
- Result:=0
- else
- Result:=EncodeDate(EY, EM, ED);
- end;
- function InternalStrToDateTime(S: string): TDateTime;
- var
- EY, EM, ED: Word;
- EH, EN, ES: Word;
- begin
- EY := StrToInt(Copy(S, 1, 4));
- EM := StrToInt(Copy(S, 6, 2));
- ED := StrToInt(Copy(S, 9, 2));
- EH := StrToInt(Copy(S, 12, 2));
- EN := StrToInt(Copy(S, 15, 2));
- ES := StrToInt(Copy(S, 18, 2));
- if (EY = 0) or (EM = 0) or (ED = 0) then
- Result := 0
- else
- Result := EncodeDate(EY, EM, ED);
- Result := Result + EncodeTime(EH, EN, ES, 0);
- end;
- function InternalStrToTime(S: string): TDateTime;
- var
- EH, EM, ES: Word;
- begin
- EH := StrToInt(Copy(S, 1, 2));
- EM := StrToInt(Copy(S, 4, 2));
- ES := StrToInt(Copy(S, 7, 2));
- Result := EncodeTime(EH, EM, ES, 0);
- end;
- function InternalStrToTimeStamp(S: string): TDateTime;
- var
- EY, EM, ED: Word;
- EH, EN, ES: Word;
- begin
- {$IFNDEF mysql40}
- EY := StrToInt(Copy(S, 1, 4));
- EM := StrToInt(Copy(S, 6, 2));
- ED := StrToInt(Copy(S, 9, 2));
- EH := StrToInt(Copy(S, 12, 2));
- EN := StrToInt(Copy(S, 15, 2));
- ES := StrToInt(Copy(S, 18, 2));
- {$ELSE}
- EY := StrToInt(Copy(S, 1, 4));
- EM := StrToInt(Copy(S, 5, 2));
- ED := StrToInt(Copy(S, 7, 2));
- EH := StrToInt(Copy(S, 9, 2));
- EN := StrToInt(Copy(S, 11, 2));
- ES := StrToInt(Copy(S, 13, 2));
- {$ENDIF}
- if (EY = 0) or (EM = 0) or (ED = 0) then
- Result := 0
- else
- Result := EncodeDate(EY, EM, ED);
- Result := Result + EncodeTime(EH, EN, ES, 0);;
- end;
- function TConnectionName.MySQLWriteData(AType: enum_field_types;ASize: Integer; AFieldType: TFieldType; BlobStrings: TStringList; Source, Dest: PChar): Boolean;
- var
- VI: Integer;
- VF: Double;
- VC: Currency;
- VD: TDateTime;
- Src : String;
- begin
- Result := False;
- if Source = Nil then
- exit;
- Src:=StrPas(Source);
- case AType of
- FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_LONG, FIELD_TYPE_LONGLONG,
- FIELD_TYPE_INT24:
- begin
- if (Src<>'') then
- VI := StrToInt(Src)
- else
- VI := 0;
- Move(VI, Dest^, SizeOf(Integer));
- end;
- {$ifdef mysql50}
- FIELD_TYPE_NEWDECIMAL,
- {$endif}
- FIELD_TYPE_DECIMAL, FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE:
- if AFieldType = ftBCD then
- begin
- VC := InternalStrToCurrency(Src);
- Move(VC, Dest^, SizeOf(Currency));
- end
- else
- begin
- if Src <> '' then
- VF := InternalStrToFloat(Src)
- else
- VF := 0;
- Move(VF, Dest^, SizeOf(Double));
- end;
- FIELD_TYPE_TIMESTAMP:
- begin
- if Src <> '' then
- VD := InternalStrToTimeStamp(Src)
- else
- VD := 0;
- Move(VD, Dest^, SizeOf(TDateTime));
- end;
- FIELD_TYPE_DATETIME:
- begin
- if Src <> '' then
- VD := InternalStrToDateTime(Src)
- else
- VD := 0;
- Move(VD, Dest^, SizeOf(TDateTime));
- end;
- FIELD_TYPE_DATE:
- begin
- if Src <> '' then
- VD := InternalStrToDate(Src)
- else
- VD := 0;
- Move(VD, Dest^, SizeOf(TDateTime));
- end;
- FIELD_TYPE_TIME:
- begin
- if Src <> '' then
- VD := InternalStrToTime(Src)
- else
- VD := 0;
- Move(VD, Dest^, SizeOf(TDateTime));
- end;
- FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET:
- begin
- { Write('Moving string of size ',asize,' : ');
- P:=Source;
- If (P<>nil) then
- While P[0]<>#0 do
- begin
- Write(p[0]);
- inc(p);
- end;
- Writeln;
- } if Src<> '' then
- Move(Source^, Dest^, ASize)
- else
- Dest^ := #0;
- end;
- FIELD_TYPE_BLOB:
- begin
- // The data is stored in the TStringlist BlobStrings and it's index is
- // stored in the record-buffer.
- vi := BlobStrings.Add(Src);
- Move(VI, Dest^, SizeOf(Integer));
- end
- end;
- Result := True;
- end;
- procedure TConnectionName.UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string);
- var qry : TSQLQuery;
- begin
- if not assigned(Transaction) then
- DatabaseError(SErrConnTransactionnSet);
- qry := tsqlquery.Create(nil);
- qry.transaction := Transaction;
- qry.database := Self;
- with qry do
- begin
- ReadOnly := True;
- sql.clear;
- sql.add('show index from ' + TableName);
- open;
- end;
- while not qry.eof do with IndexDefs.AddIndexDef do
- begin
- Name := trim(qry.fieldbyname('Key_name').asstring);
- Fields := trim(qry.fieldbyname('Column_name').asstring);
- If Name = 'PRIMARY' then options := options + [ixPrimary];
- If qry.fieldbyname('Non_unique').asinteger = 0 then options := options + [ixUnique];
- qry.next;
- { while (name = qry.fields[0].asstring) and (not qry.eof) do
- begin
- Fields := Fields + ';' + trim(qry.Fields[2].asstring);
- qry.next;
- end;}
- end;
- qry.close;
- qry.free;
- end;
- procedure TConnectionName.LoadBlobIntoStream(Field: TField;AStream: TMemoryStream;cursor: TSQLCursor;ATransaction : TSQLTransaction);
- var blobId : pinteger;
- BlobBuf : TBufBlobField;
- s : string;
- begin
- if not field.getData(@BlobBuf) then
- exit;
- blobId := @BlobBuf;
- s := (cursor as TCursorName).FBlobStrings.Strings[blobid^];
- AStream.WriteBuffer(s[1],length(s));
- AStream.seek(0,soFromBeginning);
- end;
- function TConnectionName.GetTransactionHandle(trans: TSQLHandle): pointer;
- begin
- Result:=Nil;
- end;
- function TConnectionName.Commit(trans: TSQLHandle): boolean;
- begin
- // Do nothing.
- end;
- function TConnectionName.RollBack(trans: TSQLHandle): boolean;
- begin
- // Do nothing
- end;
- function TConnectionName.StartdbTransaction(trans: TSQLHandle; AParams : string): boolean;
- begin
- // Do nothing
- end;
- procedure TConnectionName.CommitRetaining(trans: TSQLHandle);
- begin
- // Do nothing
- end;
- procedure TConnectionName.RollBackRetaining(trans: TSQLHandle);
- begin
- // Do nothing
- end;
- { TCursorName }
- constructor TCursorName.Create;
- begin
- FBlobStrings := TStringList.Create;
- inherited;
- end;
- destructor TCursorName.Destroy;
- begin
- FBlobStrings.Free;
- inherited Destroy;
- end;
- end.
|