I use Indy 10 and the TIdFTP component. It's working with the FTP protocol, but I have this error when I want to upload a .zip file to a server over FTPS/SSL.
Encryption: Required explicit FTP over TLS
Error is:
network connection was aborted by local system
This is my code:
var
fileList: TStringList;
i : integer;
ToUpload : String;
fs: TFileStream;
LHandler: TIdSSLIOHandlerSocketOpenSSL;
begin
try
LHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
with IdFTP1 do
begin
if chkSSL.Checked then
begin
IOHandler := LHandler;
LHandler.SSLOptions.SSLVersions := [sslvSSLv3,sslvTLSv1,sslvTLSv1_1,sslvTLSv1_2];
LHandler.SSLOptions.Mode := sslmClient;
UseTLS := utUseExplicitTLS;
DataPortProtection := ftpdpsPrivate;
end;
if IdFTP1.Connected then
Disconnect;
Username := edUserName;
Password := edPassword;
Host := edAddress;
if not Connected then
Connect;
end;
IdFTP1.ChangeDir(edPath + 'LocalXMLs/');
if FileExists(ExtractFilePath(Application.ExeName)+'XMLs\LocalXMLs\LocalXMLs.zip') then
begin
ToUpload := ExtractFilePath(Application.ExeName)+'XMLs\LocalXMLs\LocalXMLs.zip';
try
try
CurrStep := 3;
Application.ProcessMessages;
prgTotal.Max := 1;
ToUpload := ExtractFilePath(Application.ExeName)+'XMLs\LocalXMLs\LocalXMLs.zip';
try
try
fs := TFileStream.Create(ToUpload, fmOpenRead);
IdFTP1.TransferType := ftBinary;
IdFTP1.Put(fs, ExtractFileName(ToUpload));
Memo1.Lines.Add('3.Upload LocalXMLs.zip OK');
except
on E: Exception do
begin
Memo1.Lines.Add('Error: '+ e.Message);
FPut := true;
end;
end;
finally
fs.Free;
end;
except
on E: Exception do
begin
Memo1.Lines.Add('Error: '+ e.Message);
FPut := true;
end;
end;
finally
//fs.Free;
end;
end;
finally
IdFTP1.Quit;
Screen.Cursor := crDefault;
prgTotal.Position := 0;
LHandler.Free;
FPut := true;
end;
end;
I call this method:
FPut := false;
UploadXmlFilesWithIDFTP;
while not FPut do
Application.ProcessMessages;
...
procedure TFm_SyncMain.IdFTP1WorkEnd(Sender: TObject;
AWorkMode: TWorkMode);
begin
FGet := True;
FPut := True;
edSizeInfo.Text := 'completed.';
prgTotal.Position := 0;
end;
What did I do wrong?
Is there a way to prevent installation if a reboot/restart is already pending/required?
Our setup installs SQL Server Express and it will sometimes refuse to do so if there is a pending restart in the system. Can Inno Setup detect this condition so I can tell the user to reboot before installing our software?
I know about MakePendingFileRenameOperationsChecksum but it's usually mentioned to detect whether the reboot required condition appeared DURING the setup. Can it be used BEFORE?
If you want to detect, if there is a pending rename that requires a restart, query PendingFileRenameOperations registry value.
See also How to find out if an MSI I just installed requested a Windows reboot?
function IsRestartPending: Boolean;
var
S: string;
begin
if RegQueryMultiStringValue(
HKLM, 'SYSTEM\CurrentControlSet\Control\Session Manager',
'PendingFileRenameOperations', S) then
begin
Log(Format('PendingFileRenameOperations value exists with value [%s]', [S]));
Result := (Trim(S) <> ''); { This additional check is probably not needed }
end
else
begin
Log('PendingFileRenameOperations value does not exist');
Result := False;
end;
end;
function InitializeSetup(): Boolean;
begin
if IsRestartPending then
begin
MsgBox('Restart your machine please', mbError, MB_OK);
Result := False;
Exit;
end;
Result := True;
end;
If you need to test for other actions that may need restart, you will have to adapt the answer by #Jerry for Inno Setup.
The other accepted answer only covered one scenario. However, there are actually numerous different scenarios to check. I found this article describing all the different registry things to check, and wrote a function around it. This is actually in Delphi, but should be easily implemented in Inno Setup as well. In fact, part of it I got from here, which was in Inno Setup, for checking valid GUID.
Please note that this generally checks for pending Windows updates, which may not necessarily be desired. You can modify it and remove those checks you don't wish to perform for your purpose. The second and third checks for PendingFileRenameOperations actually appear not necessary for SQL Server.
const
S_OK = $00000000;
CO_E_CLASSSTRING = $800401F3;
type
LPCLSID = TGUID;
LPCOLESTR = WideString;
function CLSIDFromString(lpsz: LPCOLESTR; pclsid: LPCLSID): HRESULT;
stdcall; external 'ole32.dll';
function IsValidGuid(const Value: string): Boolean;
var
GUID: LPCLSID;
RetVal: HRESULT;
begin
RetVal := CLSIDFromString(LPCOLESTR(Value), GUID);
Result := RetVal = S_OK;
if not Result and (RetVal <> CO_E_CLASSSTRING) then
OleCheck(RetVal);
end;
function IsRestartPending(const RestartOnly: Boolean = True): Boolean;
var
R: TRegistry;
L: TStringList;
X: Integer;
T: String;
begin
R:= TRegistry.Create(KEY_READ);
try
L:= TStringList.Create;
try
Result:= False;
R.RootKey:= HKEY_LOCAL_MACHINE;
if R.OpenKey('SOFTWARE\Microsoft\Updates', False) then begin
try
if R.ValueExists('UpdateExeVolatile') then begin
if R.ReadInteger('UpdateExeVolatile') <> 0 then
Result:= True;
end;
finally
R.CloseKey;
end;
end;
if not RestartOnly then begin
//These next 2 checks are not necessary for a SQL Server installation.
if not Result then begin
if R.OpenKey('SYSTEM\CurrentControlSet\Control\Session Manager', False) then begin
try
Result:= R.ValueExists('PendingFileRenameOperations');
finally
R.CloseKey;
end;
end;
end;
if not Result then begin
if R.OpenKey('SYSTEM\CurrentControlSet\Control\Session Manager', False) then begin
try
Result:= R.ValueExists('PendingFileRenameOperations2');
finally
R.CloseKey;
end;
end;
end;
end;
if not Result then begin
Result:= R.KeyExists('SOFTWARE\Microsoft\Windows\CurrentVersion\WindowsUpdate\Auto Update\RebootRequired');
end;
if not Result then begin
if R.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\WindowsUpdate\Services\Pending', False) then begin
try
L.Clear;
R.GetKeyNames(L);
for X := 0 to L.Count-1 do begin
if IsValidGuid(L[X]) then begin
Result:= True;
Break;
end;
end;
finally
R.CloseKey;
end;
end;
end;
if not Result then begin
Result:= R.KeyExists('SOFTWARE\Microsoft\Windows\CurrentVersion\WindowsUpdate\Auto Update\PostRebootReporting');
end;
if not Result then begin
if R.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce', False) then begin
try
Result:= R.ValueExists('DVDRebootSignal');
finally
R.CloseKey;
end;
end;
end;
if not Result then begin
Result:= R.KeyExists('Software\Microsoft\Windows\CurrentVersion\Component Based Servicing\RebootPending');
end;
if not Result then begin
Result:= R.KeyExists('Software\Microsoft\Windows\CurrentVersion\Component Based Servicing\RebootInProgress');
end;
if not Result then begin
Result:= R.KeyExists('Software\Microsoft\Windows\CurrentVersion\Component Based Servicing\PackagesPending');
end;
if not Result then begin
Result:= R.KeyExists('SOFTWARE\Microsoft\ServerManager\CurrentRebootAttempts');
end;
if not Result then begin
if R.OpenKey('SYSTEM\CurrentControlSet\Services\Netlogon', False) then begin
try
Result:= R.ValueExists('JoinDomain');
finally
R.CloseKey;
end;
end;
end;
if not Result then begin
if R.OpenKey('SYSTEM\CurrentControlSet\Services\Netlogon', False) then begin
try
Result:= R.ValueExists('AvoidSpnSet');
finally
R.CloseKey;
end;
end;
end;
if not Result then begin
if R.OpenKey('SYSTEM\CurrentControlSet\Control\ComputerName\ActiveComputerName', False) then begin
try
T:= R.ReadString('ComputerName');
finally
R.CloseKey;
end;
end;
if R.OpenKey('SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName', False) then begin
try
if R.ReadString('ComputerName') <> T then
Result:= True;
finally
R.CloseKey;
end;
end;
end;
finally
L.Free;
end;
finally
R.Free;
end;
end;
i used a httpd to request some data from internet
function requestToServer(lParamList: TStringList) : string;
var
userDataString : string;
lHTTP: TIdHTTP;
serverResponce : string;
aobj: ISuperObject;
begin
application.ProcessMessages;
TThread.CreateAnonymousThread(
procedure
begin
lHTTP := TIdHTTP.Create(nil);
try
serverResponce := lHTTP.Post('http://domain.com/mjson.php', lParamList);
application.ProcessMessages;
aobj:= SO(serverResponce);
try
X := aobj['dta'].AsArray;
Except
form2.Memo1.Lines.Add('errr');
end;
if aobj['result'].AsString = 'lr_102' then
begin
form2.Label3.Text:='Saved token expired.';
form2.Rectangle2.Visible:=true;
end
else if aobj['result'].AsString = 'lr_103' then
begin
form2.Label3.Text:='Auto login.';
//load device data
form2.allDeviceListData := X;
form2.Hide;
form1.show;
end;
// globalReachedServer:=true;
finally
lHTTP.Free;
lParamList.Free;
end;
TThread.Synchronize(nil,
procedure
begin
end);
end
).Start();
end;
but after reach this function
the application show a black page and dont do anything until manually close
how can i do a web request at the background and with out hanging on fire-monkey !?
what a bout using REST is it better to access web service's?
Your code is not thread-safe. Your thread is directly accessing UI controls without synchronizing with the main UI thread. That alone can cause problems.
Also, all of the variables declared in the var section of requestToServer() should be moved into the var section of the anonymous procedure instead, since requestToServer() does not use them, so they can be completely local to the thread instead. The only thing the anonymous procedure should be capturing is the lParamList content.
Try something more like this:
function requestToServer(lParamList: TStringList) : string;
var
Params: TStringList;
Thread: TThread;
begin
Params := TStringList.Create;
try
Params.Assign(lParamList);
except
Params.Free;
raise;
end;
TThread.CreateAnonymousThread(
procedure
var
lHTTP: TIdHTTP;
serverResponce : string;
aObj: ISuperObject;
begin
try
try
lHTTP := TIdHTTP.Create(nil);
try
serverResponce := lHTTP.Post('http://domain.com/mjson.php', lParamList);
aObj := SO(serverResponce);
if aObj['result'].AsString = 'lr_102' then
begin
TThread.Queue(nil,
procedure
begin
form2.Label3.Text := 'Saved token expired.';
form2.Rectangle2.Visible := true;
end
);
end
else if aObj['result'].AsString = 'lr_103' then
begin
X := aObj['dta'].AsArray;
TThread.Queue(nil,
procedure
begin
form2.Label3.Text := 'Auto login.';
//load device data
form2.allDeviceListData := X;
form2.Hide;
form1.show;
end
);
end;
// globalReachedServer := true;
finally
lHTTP.Free;
end;
finally
Params.Free;
end;
except
TThread.Queue(nil,
procedure
begin
form2.Memo1.Lines.Add('errr');
end
);
end;
end
).Start;
end;
i am using indy TidTcpserver inside my server application its working good but some times after 10 clients connected my server application got a deadlock and stop from response here is my server execute and broadcast protocol codes
Tcp server execute
procedure TfMain.TCPServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command: String;
Params: array[1..10] of String;
ParamsCount, P: Integer;
PackedParams: TPackedParams;
IdBytes: TIdBytes;
MS: TMemoryStream;
ReceiveParams, ReceiveStream: Boolean;
Size: Int64;
begin
Connection := Pointer(AContext.Data);
MS := TMemoryStream.Create;
ReceiveParams := False;
ReceiveStream := False;
Command := AContext.Connection.Socket.ReadLn; //read command
if Command[1] = '1' then //command with params
begin
Command := Copy(Command, 2, Length(Command));
ReceiveParams := True;
end
else if Command[1] = '2' then //command + memorystream
begin
Command := Copy(Command, 2, Length(Command));
ReceiveStream := True;
MS.Position := 0;
end
else if Command[1] = '3' then //command with params + memorystream
begin
Command := Copy(Command, 2, Length(Command));
ReceiveParams := True;
ReceiveStream := True;
end;
if ReceiveParams then //params is incomming
begin
AContext.Connection.Socket.ReadBytes(IdBytes, SizeOf(PackedParams), False);
BytesToRaw(IdBytes, PackedParams, SizeOf(PackedParams));
ParamsCount := 0;
repeat
Inc(ParamsCount);
p := Pos(Sep, String(PackedParams.Params));
Params[ParamsCount] := Copy(String(PackedParams.Params), 1, P - 1);
Delete(PackedParams.Params, 1, P + 4);
until PackedParams.Params = '';
end;
if ReceiveStream then //stream is incomming
begin
Size := AContext.Connection.Socket.ReadInt64;
AContext.Connection.Socket.ReadStream(MS, Size, False);
MS.Position := 0;
end;
if Command = 'LOGIN' then
begin
usrnm := Params[1];
passwd := params[2];
if not userexists(usrnm, passwd) then
AContext.Connection.Socket.WriteLn('INVALIDPASSWORD')
else
begin
userslq.Close;
userslq.SQL.Clear;
userslq.SQL.Add('SELECT * FROM `users` WHERE `username` = "'+ trim(usrnm) +'" AND `password` = "' + trim(passwd) + '"');
userslq.Open;
if NOT userslq.IsEmpty then
begin
SendCommandWithParams(Connection, 'SENDYOURINFO', IntToStr(Connection.UniqueID) + Sep);
userslq.Close;
end;
userslq.Close;
userslq.SQL.Clear;
userslq.SQL.Add('UPDATE `users` SET `lastlogin` = :Date, `timeslogin`=(`timeslogin`+1) WHERE `users`.`username` = :uname;');
userslq.ParamByName('uname').AsString := trim(usrnm);
userslq.ParamByName('Date').AsDate := Now;
userslq.ExecSQL;
userslq.Close;
end;
end;
if Command = 'TAKEMYINFO' then //login ok, add to listview
begin
Connection.Name := Params[1];
Connections.Add(Connection);
AddConnectionToListView(Connection);
end;
if Command = 'TEXTMESSAGE' then
begin
BroadCastTextMessage(Params[1], Connection.UniqueID, Connection.Name, Connection.IP);
end;
if Command = 'DISCONNECTED' then
begin
DeleteConnectionFromList(Connection.UniqueID);
DeleteConnectionFromListView(Connection.UniqueID);
end;
MS.Free;
end;
broadcast Protocol and used procedures
procedure TfMain.AddConnectionToListView(Connection: TConnection);
begin
with lwConnections.Items.Add do
begin
Caption := Connection.Name;
SubItems.Add(Connection.IP);
SubItems.Add(FormatDateTime('hh:mm:ss', Connection.Connected));
SubItems.Add(IntToStr(Connection.UniqueID));
end;
end;
procedure TfMain.DeleteConnectionFromListView(UniqueID: DWord);
var
I: Integer;
begin
for I := 0 to lwConnections.Items.Count - 1 do
begin
if lwConnections.Items.Item[I].SubItems.Strings[2] = IntToStr(UniqueID) then
begin
lwConnections.Items.Delete(I);
Break;
end;
end;
end;
procedure TfMain.DeleteConnectionFromList(UniqueID: DWord);
var
I, Pos: Integer;
begin
Pos := -1;
for I := 0 to Connections.Count - 1 do
begin
if TConnection(Connections.Items[I]).UniqueID = UniqueID then
begin
Pos := I;
Break;
end;
end;
if Pos <> -1 then
Connections.Delete(Pos);
end;
procedure TfMain.BroadCastTextMessage(const TextMessage: String; const FromUniqueID: DWord;
const FromName: string; const dip: string);
var
I: Integer;
Connection: TConnection;
begin
for I := 0 to Connections.Count - 1 do
begin
Connection := Connections.Items[I];
if Connection.UniqueID <> FromUniqueID then
SendCommandWithParams(Connection, 'TEXTMESSAGE', FromName + Sep + TextMessage + Sep + dip + Sep);
end;
end;
procedure TfMain.SendCommandWithParams(Connection: TConnection; Command, Params:String);
var
PackedParams: TPackedParams;
begin
if not TIdContext(Connection.Thread).Connection.Socket.Connected then
Exit;
TCPServer.Contexts.LockList;
try
PackedParams.Params := ShortString(Params);
with TIdContext(Connection.Thread).Connection.Socket do
begin
WriteLn('1' + Command);
Write(RawToBytes(PackedParams, SizeOf(PackedParams)));
end;
finally
TCPServer.Contexts.UnlockList;
end;
end;
on connect server event
procedure Tfmain.TcpServerConnect(AContext: TIdContext);
var
Connection : TConnection;
begin
Connection := TConnection.Create;
Connection.IP := AContext.Connection.Socket.Binding.PeerIP;
Connection.Connected := Now;
Connection.UniqueID := GetTickCount;
if Connection.UniqueID = LastUniqueID then
Connection.UniqueID := GetTickCount + 1000;
LastUniqueID := Connection.UniqueID;
Connection.Thread := AContext;
AContext.Data := Connection;
end;
Updated
by following remy answer and his great details i started to do synchronize but in remy answer i am confused about TCriticalSection also i will have to rewrite the client code to be able to do same as his code doing , so i had to go with thread synchronize first here is example of what i did by following remy code i did some manage and removed database temporarily to avoid confusing here is the code of trying synchronization UI inside server execute
if Command = 'LOGIN' then
begin
if Password <> Params[1] then
AContext.Connection.Socket.WriteLn('INVALIDPASSWORD')
else
SendCommandWithParams(Connection, 'SENDYOURINFO', IntToStr(Connection.UniqueID) + Sep);
end;
if Command = 'TAKEMYINFO' then //login ok, add to listview
begin
Connection.Name := Params[1];
Connections.Add(Connection);
AddConnectionToListView(Connection);// this is not safe i know and thats what makes me confused so in this procedure call i do same as remy doing
end;
procedure TfMain.AddConnectionToListView(Connection: TConnection);
begin
TThread.Queue(nil,
procedure
var
Item: TListItem;
begin
Item := lwConnections.Items.Add;
try
Item.Caption := Connection.Name;
Item.SubItems.Add(Connection.IP);
Item.SubItems.Add(FormatDateTime('hh:mm:ss', Connection.Connected));
Item.SubItems.Add(IntToStr(Connection.UniqueID));
except
Item.Delete;
raise;
end;
end
);
end;
is this correct to synchronize ? whats makes me confused is this thread synchronize by itself ? i mean there is no thread class to execute and synchronize is this correct way ?
Updates about synchronize
Remy answer helps me i thanks him too much , but iam trying to understand thus synchronize part i found some ways on google as example include
idsync in my uses
and call it like this as example
uses
idsync;
// and in server execute i call TiDNotify To synchronize what ever i want ?
procedure TfMain.DeleteConnectionFromListView;
var
I: Integer;
begin
for I := 0 to lwConnections.Items.Count - 1 do
begin
if lwConnections.Items.Item[I].SubItems.Strings[2] = IntToStr(linetToID) then
begin
DeleteConnectionFromList(linetToID);
lwConnections.Items.Delete(I);
Break;
end;
end;
end;
procedure TfMain.TCPServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command: String;
Params: array[1..10] of String;
ParamsCount, P: Integer;
PackedParams: TPackedParams;
IdBytes: TIdBytes;
MS: TMemoryStream;
ReceiveParams, ReceiveStream: Boolean;
Size: Int64;
begin
Connection := Pointer(AContext.Data);
MS := TMemoryStream.Create;
ReceiveParams := False;
ReceiveStream := False;
Command := AContext.Connection.Socket.ReadLn; //read command
if Command[1] = '1' then //command with params
begin
Command := Copy(Command, 2, Length(Command));
ReceiveParams := True;
end
else if Command[1] = '2' then //command + memorystream
begin
Command := Copy(Command, 2, Length(Command));
ReceiveStream := True;
MS.Position := 0;
end
else if Command[1] = '3' then //command with params + memorystream
begin
Command := Copy(Command, 2, Length(Command));
ReceiveParams := True;
ReceiveStream := True;
end;
if ReceiveParams then //params is incomming
begin
AContext.Connection.Socket.ReadBytes(IdBytes, SizeOf(PackedParams), False);
BytesToRaw(IdBytes, PackedParams, SizeOf(PackedParams));
ParamsCount := 0;
repeat
Inc(ParamsCount);
p := Pos(Sep, String(PackedParams.Params));
Params[ParamsCount] := Copy(String(PackedParams.Params), 1, P - 1);
Delete(PackedParams.Params, 1, P + 4);
until PackedParams.Params = '';
end;
if ReceiveStream then //stream is incomming
begin
Size := AContext.Connection.Socket.ReadInt64;
AContext.Connection.Socket.ReadStream(MS, Size, False);
MS.Position := 0;
end;
if Command = 'LOGIN' then
begin
if Password <> Params[1] then
AContext.Connection.Socket.WriteLn('INVALIDPASSWORD')
else
SendCommandWithParams(Connection, 'SENDYOURINFO', IntToStr(Connection.UniqueID) + Sep);
end;
if Command = 'TAKEMYINFO' then //login ok, add to listview
begin
Connection.Name := Params[1];
Connections.Add(Connection);
TIdNotify.NotifyMethod(Connection.AddToListView);
end;
if Command = 'TEXTMESSAGE' then
begin
BroadCastTextMessage(Params[1], Connection.UniqueID);
end;
if Command = 'GETLIST' then
begin
SendClientsListTo(Connection.UniqueID);
end;
if Command = 'DISCONNECTED' then
begin
linetToID := Connection.UniqueID;// fmain private string variable
TIdNotify.NotifyMethod(DeleteConnectionFromListView);
end;
MS.Free;
end;
TIdTCPServer is a multi-threaded component. Its OnExecute event is triggered in the context of a worker thread. But your TAKEMYINFO and DISCONNECTED command handlers are directly accessing UI controls without synchronizing with the main UI thread. That can easily cause deadlocks (amongst other problems, including crashes, killing the UI, etc). You MUST sync!
Also, is userexists() thread-safe? Is userslq? Your use of the Connections list is definitely not thread-safe.
Why is SendCommandWithParams() locking the server's Contexts list, especially when called by OnExecute? You don't need to do that. You should be locking it in BroadCastTextMessage() instead.
Try something more like this:
type
TConnnection = class(TIdServerContext)
private
WriteLock: TCriticalSection;
public
Name: String;
IP: String;
Connected: TDateTime;
UniqueID: Dword;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure AddToListView;
procedure DeleteFromListView;
procedure BroadcastTextMessage(const TextMessage: String);
procedure SendCommandWithParams(const Command, Params: String);
procedure SendLn(const S: String);
function UserExists(const User, Passwd: string): Boolean;
procedure UpdateLastLogin(const User: String);
end;
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
WriteLock := TCriticalSection.Create;
end;
destructor TConnection.Destroy;
begin
WriteLock.Free;
inherited;
end;
procedure TConnection.AddToListView;
var
LName: string;
LIP: string;
LConnected: TDateTime;
LUniqueID: Dword;
begin
// in case the client disconnects and destroys this object before
// TThread.Queue() can update the ListView, capture the values so
// this object's fields are not accessed directly...
//
LName := Self.Name;
LIP := Self.IP;
LConnected := Self.Connected;
LUniqueID := Self.UniqueID;
TThread.Queue(nil,
procedure
var
Item: TListItem;
begin
if (fMain = nil) or (fMai.lwConnections = nil) then Exit;
Item := fMain.lwConnections.Items.Add;
try
Item.Data := Self;
Item.Caption := LName;
Item.SubItems.Add(LIP);
Item.SubItems.Add(FormatDateTime('hh:mm:ss', LConnected));
Item.SubItems.Add(IntToStr(LUniqueID));
except
Item.Delete;
raise;
end;
end
);
end;
procedure TConnection.DeleteFromListView;
begin
TThread.Queue(nil,
procedure
var
Item: TListItem;
begin
if (fMain = nil) or (fMai.lwConnections = nil) then Exit;
Item := fMain.lwConnections.FindData(0, Self, True, False);
if Item <> nil then Item.Delete;
end
);
end;
procedue TConnection.BroadCastTextMessage(const TextMessage: String);
var
List: TList; // or TIdContextList if using a modern Indy version
I: Integer;
Connection: TConnection;
begin
List := Server.Contexts.LockList;
try
for I := 0 to List.Count - 1 do
begin
Connection := TConnection(List.Items[I]);
if Connection <> Self then
begin
try
Connection.SendCommandWithParams('TEXTMESSAGE', FromName + Sep + TextMessage + Sep + dip + Sep);
except
end;
end;
finally
Server.Contexts.UnlockList;
end;
end;
procedure TConnection.SendCommandWithParams(const Command, Params: String);
var
PackedParams: TPackedParams;
begin
PackedParams.Params := ShortString(Params);
WriteLock.Enter;
try
with Connection.Socket do
begin
WriteLn('1' + Command);
Write(RawToBytes(PackedParams, SizeOf(PackedParams)));
end;
finally
WriteLock.Leave;
end;
end;
procedure TConnection.SendLn(const S: String);
begin
WriteLock.Enter;
try
Connection.Socket.WriteLn(S);
finally
WriteLock.Leave;
end;
end;
function TConnection.UserExists(const User, Passwd: string): Boolean;
var
Exists: Boolean;
begin
// if you give each client its own DB connection, or use
// a thread-safe DB pool, you don't have to sync this ...
//
TThread.Synchronize(nil,
procedure
if (fMain = nil) or (fMai.userslq = nil) then Exit;
with fMain.userslq do
begin
Close;
SQL.Text := 'SELECT * FROM `users` WHERE `username` = :uname AND `password` = :passwd;';
ParamByName('uname').AsString := Trim(User);
ParamByName('passwd').AsString := Trim(Passwd);
Open;
try
Exists := not IsEmpty;
finally
Close;
end;
end;
end
);
Result := Exists;
end;
procedure TConnection.UpdateLastLogin(const User: String);
begin
// if you give each client its own DB connection, or use
// a thread-safe DB pool, you don't have to sync this ...
//
TThread.Synchronize(nil,
procedure
if (fMain = nil) or (fMai.userslq = nil) then Exit;
with fMain.userslq do
begin
Close;
SQL.Text := 'UPDATE `users` SET `lastlogin` = :Date, `timeslogin`=(`timeslogin`+1) WHERE `users`.`username` = :uname;';
ParamByName('uname').AsString := Trim(User);
ParamByName('Date').AsDate := Now;
ExecSQL;
Close;
end;
end
);
end;
procedure TfMain.FormCreate(Sender: TObject);
begin
// set this before activating the server
TCPServer.ContextClass := TConnection;
end;
procedure TfMain.TCPServerConnect(AContext: TIdContext);
var
Connection: TConnection;
begin
Connection := AContext as TConnection;
Connection.Name := '';
Connection.IP := AContext.Binding.PeerIP;
Connection.Connected := Now;
Connection.UniqueID := ...;
end;
procedure TfMain.TCPServerDisconnect(AContext: TIdContext);
var
Connection: TConnection;
begin
Connection := AContext as TConnection;
Connection.DeleteFromListView;
end;
procedure TfMain.TCPServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command: String;
Params: array[1..10] of String;
ParamsCount, P: Integer;
PackedParams: TPackedParams;
IdBytes: TIdBytes;
MS: TMemoryStream;
ReceiveParams, ReceiveStream: Boolean;
S: String;
begin
Connection := AContext as TConnection;
Command := AContext.Connection.Socket.ReadLn; //read command
if Command = '' then Exit;
ReceiveParams := False;
ReceiveStream := False;
if Command[1] = '1' then //command with params
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := True;
end
else if Command[1] = '2' then //command + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveStream := True;
end
else if Command[1] = '3' then //command with params + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := True;
ReceiveStream := True;
end;
if ReceiveParams then //params is incomming
begin
AContext.Connection.Socket.ReadBytes(IdBytes, SizeOf(PackedParams), False);
BytesToRaw(IdBytes, PackedParams, SizeOf(PackedParams));
S := String(PackedParams.Params);
ParamsCount := 0;
while (S <> '') and (ParamsCount < 10) do
begin
Inc(ParamsCount);
p := Pos(Sep, S);
if p = 0 then
Params[ParamsCount] := S
else
begin
Params[ParamsCount] := Copy(S, 1, P - 1);
Delete(S, 1, P + 4);
end;
end;
end;
MS := nil;
try
if ReceiveStream then //stream is incomming
begin
MS := TMemoryStream.Create;
AContext.Connection.Socket.LargeStream := True;
AContext.Connection.Socket.ReadStream(MS, -1, False);
MS.Position := 0;
end;
if Command = 'LOGIN' then
begin
if ParamsCount <> 2 then
begin
Connection.SendLn('INVALIDPARAMS');
Exit;
end;
if not Connection.UserExists(Params[1], Params[2]) then
begin
Connection.SendLn('INVALIDPASSWORD');
Exit;
end;
Connection.UpdateLastLogin(Params[1]);
Connection.SendCommandWithParams('SENDYOURINFO', IntToStr(Connection.UniqueID) + Sep);
end
else if Command = 'TAKEMYINFO' then //login ok, add to listview
begin
if ParamsCount <> 1 then
begin
Connection.SendLn('INVALIDPARAMS');
Exit;
end;
Connection.Name := Params[1];
Connection.AddToListView;
end
else if Command = 'TEXTMESSAGE' then
begin
if ParamsCount <> 1 then
begin
Connection.SendLn('INVALIDPARAMS');
Exit;
end;
Connection.BroadCastTextMessage(Params[1]);
end
else if Command = 'DISCONNECTED' then
begin
AContext.Connection.Disconnect;
Exit;
end;
finally
MS.Free;
end;
end;
I'm using Delphi 5 + BDE + Oracle. I have the following function:
class function TClientDataSetFactory.GetClientDataSet(
const qryGen: TDataSet): TClientDataSet;
var
dspDados: TDataSetProvider;
begin
Result := nil;
try
try
Result := TClientDataSet.Create(nil);
dspDados := TDataSetProvider.Create(Result);
dspDados.DataSet := qryGen;
qryGen.Active := True;
qryGen.First;
Result.Data := dspDados.Data;
Result.First;
except
on E: Exception do
begin
raise;
end;
end;
finally
end;
end;
so, when a run this:
var
qryGen: TQuery;
cdsGen: TClientDataSet;
begin
qryGen := nil;
try
try
qryGen := CriaQuery();
qryGen.SQL.Text :=
'SELECT SUM(TOTAL) AS TOTAL FROM MYTABLE';
cdsGen := TClientDataSetFactory.GetClientDataSet(qryGen);
ShowMessageFmt('Total: %f', [cdsGen.FieldByName('TOTAL').AsFloat]);
except
on E: Exception do
begin
raise;
end;
end;
finally
if Assigned(qryGen) then FreeAndNil(qryGen);
end;
end;
i got "159,00" but, if i run this:
ShowMessageFmt('Total: %f', [qryGen.FieldByName('TOTAL').AsFloat]);
i got "159,25".
can someone help me?
I solved the problem with another solution.
type
TInternalQuery = class(TQuery)
protected
procedure InternalInitFieldDefs; override;
public
constructor Create(AOwner: TComponent; const qryGen: TQuery); reintroduce;
end;
constructor TInternalQuery.Create(AOwner: TComponent; const qryGen: TQuery);
var
intCont: Integer;
begin
inherited Create(AOwner);
Self.DatabaseName := qryGen.DatabaseName;
Self.UpdateObject := qryGen.UpdateObject;
Self.SQL.Text := qryGen.SQL.Text;
for intCont := 0 to Self.ParamCount - 1 do
begin
Self.Params[intCont].Value := qryGen.Params[intCont].Value;
end;
end;
procedure TInternalQuery.InternalInitFieldDefs;
var
intCont: Integer;
begin
inherited InternalInitFieldDefs;
for intCont := 0 to FieldDefs.Count - 1 do
begin
if (FieldDefs[intCont].Size = 0) and (FieldDefs[intCont].DataType = ftBCD) then
begin
FieldDefs[intCont].Precision := 64;
FieldDefs[intCont].Size := 32;
end;
end;
end;
the problem is ((FieldDefs[intCont].Size = 0) and (FieldDefs[intCont].DataType = ftBCD)). when ClientDataSet is created, the field is truncated, because when oracle has a function like "SUM(TOTAL)" the result field is created with size 0, so the clientdataset handle the field as Integer field.
Try with
ShowMessageFmt('Total: %n', [cdsGen.FieldByName('TOTAL').AsFloat])
or this
cdsGen := TClientDataSetFactory.GetClientDataSet(qryGen);
**(cdsGen.FieldByName('Total') as TFloatField).DisplayFormat := '0.00';**
ShowMessageFmt('Total: %f', [cdsGen.FieldByName('TOTAL').AsFloat])