Problems getting the JSON data from DLL using SuperObject and OmniThreadLibrary - delphi

I'm using Delphi XE, I have the following code for my program and DLL:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, superobject,
OtlCommon, OtlCollections, OtlParallel;
type
TForm1 = class(TForm)
btnStart: TButton;
btnStop: TButton;
procedure btnStartClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
FLogger : IOmniBackgroundWorker;
FPipeline: IOmniPipeline;
FLogFile: TextFile;
strict protected
procedure Async_Log(const workItem: IOmniWorkItem);
procedure Async_Files(const input, output: IOmniBlockingCollection);
procedure Async_Parse(const input: TOmniValue; var output: TOmniValue);
procedure Async_JSON(const input, output: IOmniBlockingCollection);
end;
var
Form1: TForm1;
function GetJSON(AData: PChar): ISuperObject; stdcall; external 'my.dll';
implementation
uses OtlTask, IOUtils;
{$R *.dfm}
function GetJSON_local(AData: PChar): ISuperObject;
var
a: ISuperObject;
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := StrPas(AData);
Result := SO();
Result.O['array'] := SA([]);
a := SO;
a.S['item1'] := sl[14];
Result.A['array'].Add(a);
a := nil;
a := SO;
a.S['item2'] := sl[15];
Result.A['array'].Add(a);
finally
sl.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
s: string;
begin
// log
s := ExtractFilePath(Application.ExeName) + 'Logs';
if not TDirectory.Exists(s) then TDirectory.CreateDirectory(s);
s := Format(s+'\%s.txt', [FormatDateTime('yyyy-mm-dd_hh-nn-ss', Now)]);
AssignFile(FLogFile, s);
Rewrite(FLogFile);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
CloseFile(FLogFile);
end;
procedure TForm1.Async_Log(const workItem: IOmniWorkItem);
begin
WriteLn(FLogFile, workItem.Data.AsString);
end;
procedure TForm1.Async_Files(const input, output: IOmniBlockingCollection);
var
f: string;
begin
while not input.IsCompleted do begin
for f in TDirectory.GetFiles(ExtractFilePath(Application.ExeName), '*.txt') do
output.TryAdd(f); // output as FileName
Sleep(1000);
end;
end;
procedure TForm1.Async_Parse(const input: TOmniValue; var output: TOmniValue);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(input.AsString);
// output := GetJSON_local(PChar(sl.Text)); // output as ISuperObject --- local function
output := GetJSON(PChar(sl.Text)); // output as ISuperObject --- DLL function
finally
sl.Free;
end;
FLogger.Schedule(FLogger.CreateWorkItem(Format('%s - File processed: %s', [DateTimeToStr(Now), input.AsString])));
end;
procedure TForm1.Async_JSON(const input, output: IOmniBlockingCollection);
var
value: TOmniValue;
JSON: ISuperObject;
begin
for value in input do begin
if value.IsException then begin
FLogger.Schedule(FLogger.CreateWorkItem(value.AsException.Message));
value.AsException.Free;
end
else begin
JSON := value.AsInterface as ISuperObject;
FLogger.Schedule(FLogger.CreateWorkItem(JSON.AsString));
end;
end;
end;
//
procedure TForm1.btnStartClick(Sender: TObject);
begin
btnStart.Enabled := False;
FLogger := Parallel.BackgroundWorker.NumTasks(1).Execute(Async_Log);
FPipeline := Parallel.Pipeline
.Stage(Async_Files)
.Stage(Async_Parse)
.Stage(Async_JSON)
.Run;
end;
procedure TForm1.btnStopClick(Sender: TObject);
begin
if Assigned(FPipeline) and Assigned(FLogger) then begin
FPipeline.Input.CompleteAdding;
FPipeline := nil;
FLogger.Terminate(INFINITE);
FLogger := nil;
end;
btnStart.Enabled := True;
end;
end.
// DLL code
library my;
uses
SysUtils,
Classes, superobject;
function GetJSON(AData: PChar): ISuperObject; stdcall;
var
a: ISuperObject;
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := StrPas(AData);
Result := SO();
Result.O['array'] := SA([]);
a := SO;
a.S['item1'] := sl[14];
Result.A['array'].Add(a);
a := nil;
a := SO;
a.S['item2'] := sl[15];
Result.A['array'].Add(a);
finally
sl.Free;
end;
end;
exports
GetJSON;
begin
end.
When I try to run with debugging my code, after a few calls of the dll GetJSON function i get the following error:
"Project test_OTL_SO.exe raised exception class EAccessViolation with message 'Access violation at address 005A2F8A in module 'my.dll'. Write of address 00610754'."
However, this issue does not occur when I use the same local function GetJSON_local.
Could anyone suggest what am I doing wrong here?
EDIT: (solution)
I write this code for my DLL:
procedure GetJSON_(const AData: PChar; out Output: WideString); stdcall;
var
json, a: ISuperObject;
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := AData;
json := SO();
json.O['array'] := SA([]);
a := SO;
a.S['item1'] := sl[14];
json.A['array'].Add(a);
a := nil;
a := SO;
a.S['item2'] := sl[15];
json.A['array'].Add(a);
Output := json.AsString;
finally
sl.Free;
end;
end;
and changed the code of Async_Parse procedure:
procedure TForm1.Async_Parse(const input: TOmniValue; var output: TOmniValue);
var
sl: TStringList;
ws: WideString;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(input.AsString);
GetJSON_(PChar(sl.Text), ws); // DLL procedure
output := SO(ws); // output as ISuperObject
finally
sl.Free;
end;
FLogger.Schedule(FLogger.CreateWorkItem(Format('%s - File processed: %s', [DateTimeToStr(Now), input.AsString])));
end;

The problem is your passing of ISuperObject interfaces across a module boundary. Although interfaces can be safely used that way, the methods of the interface are not safe. Some of the methods of the interface accept, or return, strings, objects, etc. That is, types that are not safe for interop.
Some examples of methods that are not safe:
function GetEnumerator: TSuperEnumerator; // TSuperEnumerator is a class
function GetS(const path: SOString): SOString; // returns a Delphi string
function SaveTo(stream: TStream; indent: boolean = false;
escape: boolean = true): integer; overload; // TStream is a class
function AsArray: TSuperArray; // TSuperArray is a class
// etc.
You should serialize the JSON to text, and pass that text between your modules.

Related

How to access Tag property

How can I access HTTPRIO.Tag previously assigned from, for instance, the HTTPRIO.OnBeforeExecute event? Is it possible?
Let's say I have something like this:
procedure TForm1.HTTPRIO1BeforeExecute(const MethodName: string; SOAPRequest: TStream);
begin
if THHPRIO(Sender).Tag = 99 then
...some code...
end;
But I don't have a Sender on any of the THTTPRIO events.
Since you are assigning events to multiple THTTPRIO objects, but don't have access to a Sender parameter in the events (bad design on THTTPRIO's author), one workaround is to use the TMethod record to manipulate the event handler's Self pointer to point at the THTTPRIO object rather than the TForm1 object, eg:
procedure TForm1.FormCreate(Sender: TObject);
var
M: TBeforeExecuteEvent;
begin
M := HTTPRIOBeforeExecute;
TMethod(M).Data := HTTPRIO1;
HTTPRIO1.OnBeforeExecute := M;
M := HTTPRIOBeforeExecute;
TMethod(M).Data := HTTPRIO2;
HTTPRIO2.OnBeforeExecute := M;
// and so on ...
end;
And then you can type-cast Self inside the events, eg:
procedure TForm1.HTTPRIOBeforeExecute(const MethodName: string; SOAPRequest: TStream);
begin
if THTTPRIO(Self).Tag = 99 then
...some code...
end;
Alternatively, you can use a standalone procedure (or class static method) with an explicit parameter for the Self pointer, eg:
procedure HTTPRIOBeforeExecute(Sender: THTTPRIO; const MethodName: string; SOAPRequest: TStream);
begin
if Sender.Tag = 99 then
...some code...
end;
procedure TForm1.FormCreate(Sender: TObject);
var
M: TBeforeExecuteEvent;
begin
TMethod(M).Data := HTTPRIO1;
TMethod(M).Code := #HTTPRIOBeforeExecute;
HTTPRIO1.OnBeforeExecute := M;
TMethod(M).Data := HTTPRIO2;
TMethod(M).Code := #HTTPRIOBeforeExecute;
HTTPRIO2.OnBeforeExecute := M;
// and so on ...
end;
While Remy's solution works, leaving the code in TForm1 leaves you at risk of accidentally referencing fields from TForm1 in TForm1.HTTPRIOBeforeExecute, and since "Self" isn't a TForm1 anymore, that would crash/corrupt memory.
I would personally use the following approach :
THTTPRIOMethodHolder = class(THTTPRIO)
public
procedure HTTPRIOBeforeExecute(const MethodName: string; SOAPRequest: TStream);
end;
procedure THTTPRIOMethodHolder.HTTPRIOBeforeExecute(const MethodName: string; SOAPRequest: TStream);
begin
if {self.}Tag = 99 then
...some code...
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HTTPRIO1.OnBeforeExecute := THTTPRIOMethodHolder(HTTPRIO1).HTTPRIOBeforeExecute;
HTTPRIO2.OnBeforeExecute := THTTPRIOMethodHolder(HTTPRIO2).HTTPRIOBeforeExecute;
end;
This should work as long as you don't add fields in THTTPRIOMethodHolder and HTTPRIOBeforeExecute is not made virtual.
Well, I actualy not leaving the code in TForm1.
I'm doing something like this:
type
THTTPRIO_EventHandlers_v2 = Class
procedure HTTPRIOBeforeExecute(const MethodName: String; SOAPRequest: TStream);
procedure HTTPRIOAfterExecute(const MethodName: string; SOAPResponse: TStream);
end;
type
THTTPRIOBeforeExecute = procedure(const MethodName: String; SPRequest: TStream) of Object;
THTTPRIOAfterExecute = procedure(const MethodName: string; SOAPResponse: TStream) of Object;
var
HTTPRIO: THTTPRIO;
procedure TForm1.Button1Click(Sender: TObject)
var
RIO_Events: THTTPRIO_EventHandlers_v2;
EvtHTTPRIOBeforeExecute: THTTPRIOBeforeExecute;
EvtHTTPRIOAfterExecute: THTTPRIOAfterExecute;
begin
HTTPRIO := THTTPRIO.Create(Application);
HTTPRIO.Tag := 99;
HTTPRIO.Converter.Encoding := 'utf-8';
RIO_Events := THTTPRIO_EventHandlers_v2.Create;
EvtHTTPRIOBeforeExecute := RIO_Events.HTTPRIOBeforeExecute;
TMethod(EvtHTTPRIOBeforeExecute).Data := HTTPRIO;
HTTPRIO.OnBeforeExecute := EvtHTTPRIOBeforeExecute;
EvtHTTPRIOAfterExecute := RIO_Events.HTTPRIOAfterExecute;
TMethod(EvtHTTPRIOAfterExecute).Data := HTTPRIO;
HTTPRIO.OnAfterExecute := EvtHTTPRIOAfterExecute;
RIO_Events.Free;
end;
And on the, for instance, HTTPRIOBeforeExecute procedure, I'm doing this:
procedure THTTPRIO_EventHandlers_v2.HTTPRIOBeforeExecute(const MethodName: String; SOAPRequest: TStream);
var
HttpRioTag: Integer;
begin
HttpRioTag := THTTPRIO(Self).Tag;
if HttpRioTag = 99 then
...some code...
end;
This is working as expected.
Am I doing it the right way?
Thanks

delphi E2009 Incompatible types: 'Parameter lists differ'

I was trying to compile this delphi code:
delphi UDP server
unit UDP.Server;
interface
uses
IdUDPServer,
IdSocketHandle,
System.SysUtils;
type
TResponseToMessage = reference to function(const AMsg : string):string;
TUDPServer = class
strict private const
DEFAULT_UDP_PORT = 49152;
strict private
FidUDPServer : TIdUDPServer;
FResponseToMessage: TResponseToMessage;
FEndOfProtocol: string;
class var FInstance : TUDPServer;
constructor Create();
destructor Free();
procedure UDPRead (AThread: TIdUDPListenerThread; AData: TArray<System.Byte>; ABinding: TIdSocketHandle);
private
class procedure ReleaseInstance();
public
procedure SetReponseToMessage(AFunction : TResponseToMessage);
procedure SetUDPPort(const APort : word);
procedure StartListen();
property EndOfProtocol : string read FEndOfProtocol write FEndOfProtocol;
class function GetInstance() : TUDPServer;
end;
implementation
{ TUdpServer }
constructor TUDPServer.Create;
begin
Self.FidUDPServer := TIdUDPServer.Create(nil);
Self.FidUDPServer.OnUDPRead := Self.UDPRead;
Self.FidUDPServer.DefaultPort := Self.DEFAULT_UDP_PORT;
end;
destructor TUDPServer.Free;
begin
Self.FidUDPServer.Free;
end;
class function TUDPServer.GetInstance: TUDPServer;
begin
if not Assigned(Self.FInstance) then
Self.FInstance := TUDPServer.Create();
Result := Self.FInstance;
end;
class procedure TUDPServer.ReleaseInstance;
begin
if Assigned(Self.FInstance) then
Self.FInstance.Free;
end;
procedure TUDPServer.SetReponseToMessage(AFunction: TResponseToMessage);
begin
Self.FResponseToMessage := AFunction;
end;
procedure TUDPServer.SetUDPPort(const APort: word);
begin
Self.FidUDPServer.Active := false;
Self.FidUDPServer.DefaultPort := APort;
Self.FidUDPServer.Active := true;
end;
procedure TUDPServer.StartListen;
begin
if not Self.FidUDPServer.Active then
Self.FidUDPServer.Active := true;
end;
procedure TUDPServer.UDPRead(AThread: TIdUDPListenerThread;
AData: TArray<System.Byte>; ABinding: TIdSocketHandle);
var
sResponse: string;
begin
sResponse := EmptyStr;
if Assigned(Self.FResponseToMessage) then
sResponse := Self.FResponseToMessage(StringOf(AData));
if sResponse <> EmptyStr then
ABinding.SendTo(ABinding.PeerIP,ABinding.PeerPort,sResponse);
ABinding.SendTo(ABinding.PeerIP,ABinding.PeerPort,Self.FEndOfProtocol);
end;
initialization
finalization
TUDPServer.ReleaseInstance();
end.
I get the error on Self.FidUDPServer.OnUDPRead := Self.UDPRead; line
E2009 Incompatible types: 'Parameter lists differ'
I can't figure out what is causing this error.
Replace TArray<System.Byte> with TIdBytes as that is what Indy is expecting you to use here. The code you have is likely from an older version of Indy.

How to make my file DropSouce be accepted by all targets that works with files?

I made a control that represents a list of files and I want to be able to drag the files from my control to other applications that work with files. I implemented the IDragSource interface (as shown below) but when I drag, the files are accepted only by windows explorer, other applications like Firefox, Yahoo Messenger, Photoshop... do not accept my files. What have I done wrong ? I have a feeling that IDataObject is not set correctly and I'm afraid I have to implemet it myself... and this is a very coplicated job for me to do because I just started to work with interfaces.
Here is the code to reproduce the problem:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ActiveX, ShlObj;
type
TMyControl = class(TMemo, IDropSource)
private
function QueryContinueDrag(fEscapePressed:BOOL; grfKeyState:Longint):HResult; stdcall;
function GiveFeedback(dwEffect:Longint):HResult; stdcall;
procedure DoDragAndDrop;
function GetFileListDataObject:IDataObject;
protected
procedure MouseMove(Shift:TShiftState; X,Y:Integer); override;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
public
MyMemo:TMyControl;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{TMyControl}
function TMyControl.QueryContinueDrag(fEscapePressed:BOOL; grfKeyState:Longint):HResult;
begin
if fEscapePressed then Result:=DRAGDROP_S_CANCEL
else if (grfKeyState and (MK_LBUTTON or MK_RBUTTON) = 0) then Result:=DRAGDROP_S_DROP
else Result:=S_OK;
end;
function TMyControl.GiveFeedback(dwEffect:Longint):HResult;
begin
Result:=DRAGDROP_S_USEDEFAULTCURSORS;
end;
procedure TMyControl.DoDragAndDrop;
var AllowedEffects,DropEffect:Longint;
DataObj:IDataObject;
begin
AllowedEffects:=DROPEFFECT_COPY;
DataObj:=GetFileListDataObject;
if DataObj <> nil then
DoDragDrop(DataObj, self, AllowedEffects, DropEffect);
end;
function TMyControl.GetFileListDataObject:IDataObject;
var Desktop:IShellFolder;
Attr,Eaten:ULONG;
Count,x:Integer;
Pidls:array of PItemIDList;
begin
Result:=nil;
Count:=Lines.Count;
if Count<1 then Exit;
if Failed(SHGetDesktopFolder(Desktop)) then Exit;
SetLength(Pidls,Count);
for x:=0 to Count-1 do Pidls[x]:=nil;
try
for x:=0 to Count-1 do
if Failed(Desktop.ParseDisplayName(0, nil, PWideChar(Lines[x]), Eaten, Pidls[x], Attr)) then Exit;
Desktop.GetUIObjectOf(0, Count, Pidls[0], IDataObject, nil, Result);
finally
for x:=0 to Count-1 do
if Pidls[x]<>nil then CoTaskMemFree(Pidls[x]);
end;
end;
procedure TMyControl.MouseMove(Shift:TShiftState; X,Y:Integer);
begin
if ssLeft in Shift then DoDragAndDrop;
inherited;
end;
//---------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
MyMemo:=TMyControl.Create(Form1);
MyMemo.Parent:=Form1;
MyMemo.Align:=alClient;
end;
end.
The problem is you use incorrect call of Desktop.GetUIObjectOf. When you call SomeFolder.GetUIObjectOf items MUST be childs of SomeFolder. But in your case it is not true. Try something like this:
type
PPItemIDList = ^PItemIDList;
function GetFileListDataObject(AParentWnd: HWND; const APath: string; AFileNames: TStrings): IDataObject;
var
Desktop: IShellFolder;
Eaten, Attr: ULONG;
i: Integer;
PathIDList: PItemIDList;
PathShellFolder: IShellFolder;
IDLists: PPItemIDList;
IDListsSize: Integer;
Pos: PPItemIDList;
begin
Result := nil;
if AFileNames.Count < 1 then Exit;
if Failed(SHGetDesktopFolder(Desktop)) then Exit;
try
Attr := 0;
if Failed(Desktop.ParseDisplayName(AParentWnd, nil, PWideChar(APath), Eaten, PathIDList, Attr)) then Exit;
try
if Failed(Desktop.BindToStorage(PathIDList, nil, IShellFolder, PathShellFolder)) then Exit;
try
IDListsSize := SizeOf(PItemIDList) * AFileNames.Count;
GetMem(IDLists, IDListsSize);
try
ZeroMemory(IDLists, IDListsSize);
Pos := IDLists;
for i := 0 to AFileNames.Count - 1 do
begin
Attr := 0;
if Failed(PathShellFolder.ParseDisplayName(0, nil, PWideChar(AFileNames[i]), Eaten, Pos^, Attr)) then Exit;
Inc(Pos);
end;
PathShellFolder.GetUIObjectOf(0, AFileNames.Count, IDLists^, IDataObject, nil, Result);
finally
Pos := IDLists;
for i := 0 to AFileNames.Count - 1 do
begin
if Assigned(Pos^) then
CoTaskMemFree(Pos^);
Inc(Pos);
end;
FreeMem(IDLists);
end;
finally
PathShellFolder := nil;
end;
finally
CoTaskMemFree(PathIDList);
end;
finally
Desktop := nil;
end;
end;

Delphi synapse UDP client/server

I need to create server and client programs with synapse using UDP protocol.
I have created the server program to listen to any coming messages like this
procedure TForm1.Timer1Timer(Sender: TObject);
var
resive:string;
begin
InitSocket;
resive:=UDPResiveSocket.RecvPacket(1000);
if resive<>'' then Memo1.Lines.Add('>' + resive);
DeInitSocket;
end;
procedure TForm1.InitSocket;
begin
if UDPResiveSocket <> nil then
DeInitSocket;
UDPResiveSocket := TUDPBlockSocket.Create;
UDPResiveSocket.CreateSocket;
UDPResiveSocket.Bind('0.0.0.0','22401');
UDPResiveSocket.AddMulticast('234.5.6.7');
UDPResiveSocket.MulticastTTL := 1;
end;
procedure TForm1.DeInitSocket;
begin
UDPResiveSocket.CloseSocket;
UDPResiveSocket.Free;
UDPResiveSocket := nil;
end;
So i get all incoming messages.
But i want to send a response from the source of this messages.
How can i do that? Does my method is good for server/client?
My UDP Echo client / server code. First the server:
unit UE_Server;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
// synapse
blcksock;
type
{ TUEServerThread }
TUEServerThread = class(TThread)
protected
procedure Execute; override;
end;
TUEServer = class
private
FUEServerThread: TUEServerThread;
function GetRunning: Boolean;
public
procedure Stop;
procedure Start;
property Running: Boolean read GetRunning;
end;
implementation
{ TUEServer }
function TUEServer.GetRunning: Boolean;
begin
Result := FUEServerThread <> nil;
end;
procedure TUEServer.Start;
begin
FUEServerThread := TUEServerThread.Create(False);
end;
procedure TUEServer.Stop;
begin
if FUEServerThread <> nil then
begin
FUEServerThread.Terminate;
FUEServerThread.WaitFor;
FreeAndNil(FUEServerThread);
end;
end;
{ TUEServerThread }
procedure TUEServerThread.Execute;
var
Socket: TUDPBlockSocket;
Buffer: string;
Size: Integer;
begin
Socket := TUDPBlockSocket.Create;
try
Socket.Bind('0.0.0.0', '7');
try
if Socket.LastError <> 0 then
begin
raise Exception.CreateFmt('Bind failed with error code %d', [Socket.LastError]);
Exit;
end;
while not Terminated do
begin
// wait one second for new packet
Buffer := Socket.RecvPacket(1000);
if Socket.LastError = 0 then
begin
// just send the same packet back
Socket.SendString(Buffer);
end;
// minimal sleep
if Buffer = '' then
Sleep(10);
end;
finally
Socket.CloseSocket;
end;
finally
Socket.Free;
end;
end;
end.
Then the client:
unit UE_Client;
{$mode objfpc}{$H+}
interface
uses
{$IFDEF WINDOWS}Windows,{$ENDIF}Classes, SysUtils, DateUtils,
// synapse
blcksock;
const
cReceiveTimeout = 2000;
cBatchSize = 100;
type
{ TUEClient }
TUEClient = class
private
FSocket: TUDPBlockSocket;
FResponseTime: Int64;
public
constructor Create;
destructor Destroy; override;
procedure Disconnect;
function Connect(const Address: string): Boolean;
function SendEcho(const Message: string): string;
property ReponseTime: Int64 read FResponseTime;
end;
{ TUEAnalyzer }
{ TUEAnalyzerThread }
TUEAnalyzerThread = class(TThread)
private
FAddress: string;
FBatchDelay: Cardinal;
FDropedPackets: Cardinal;
FAverageResponse: Extended;
FCriticalSection: TRTLCriticalSection;
function GetAverageResponse: Extended;
function GetDropedPackets: Cardinal;
protected
procedure Execute; override;
public
destructor Destroy; override;
constructor Create(const Address: string; const BatchDelay: Cardinal);
property DropedPackets: Cardinal read GetDropedPackets;
property AverageResponse: Extended read GetAverageResponse;
end;
TUEAnalyzer = class
private
FAddress: string;
FBatchDelay: Cardinal;
FAnalyzerThread: TUEAnalyzerThread;
function GetAverageResponse: Extended;
function GetDropedPackets: Cardinal;
function GetRunning: Boolean;
public
procedure StopAnalyzer;
procedure StartAnalyzer;
property Running: Boolean read GetRunning;
property Address: string read FAddress write FAddress;
property DropedPackets: Cardinal read GetDropedPackets;
property AverageResponse: Extended read GetAverageResponse;
property BatchDelay: Cardinal read FBatchDelay write FBatchDelay;
end;
implementation
{ TUEAnalyzerThread }
function TUEAnalyzerThread.GetAverageResponse: Extended;
begin
EnterCriticalsection(FCriticalSection);
try
Result := FAverageResponse;
finally
LeaveCriticalsection(FCriticalSection);
end;
end;
function TUEAnalyzerThread.GetDropedPackets: Cardinal;
begin
EnterCriticalsection(FCriticalSection);
try
Result := FDropedPackets;
finally
LeaveCriticalsection(FCriticalSection);
end;
end;
procedure TUEAnalyzerThread.Execute;
var
UEClient: TUEClient;
Connected: Boolean;
SendString: string;
SendCounter: Int64;
SumResponse: Cardinal;
SumDropedPackets: Cardinal;
begin
UEClient := TUEClient.Create;
try
Connected := UEClient.Connect(FAddress);
try
if not Connected then
begin
raise Exception.CreateFmt('Could not connect UPD client to address %s', [FAddress]);
Exit;
end;
SumDropedPackets := 0;
FAverageResponse := 0;
FDropedPackets := 0;
SumResponse := 0;
SendCounter := 1;
while not Terminated do
begin
SendString := IntToStr(SendCounter);
if not (UEClient.SendEcho(SendString) = SendString) then
Inc(SumDropedPackets);
Inc(SumResponse, UEClient.ReponseTime);
Inc(SendCounter);
if (SendCounter mod cBatchSize) = 0 then
begin
EnterCriticalsection(FCriticalSection);
try
FAverageResponse := SumResponse / cBatchSize;
FDropedPackets := SumDropedPackets;
finally
LeaveCriticalsection(FCriticalSection);
end;
// sleep for specified batch time
Sleep(FBatchDelay * 1000);
SumDropedPackets := 0;
SumResponse := 0;
end;
// minimal sleep
Sleep(10);
end;
finally
UEClient.Disconnect;
end;
finally
UEClient.Free;
end;
end;
destructor TUEAnalyzerThread.Destroy;
begin
{$IFDEF MSWINDOWS}
DeleteCriticalSection(FCriticalSection)
{$ELSE}
DoneCriticalSection(FCriticalSection)
{$ENDIF};
inherited Destroy;
end;
constructor TUEAnalyzerThread.Create(const Address: string; const BatchDelay: Cardinal);
begin
{$IFDEF MSWINDOWS}
InitializeCriticalSection(FCriticalSection)
{$ELSE}
InitCriticalSection(FCriticalSection)
{$ENDIF};
FBatchDelay := BatchDelay;
FreeOnTerminate := True;
FAddress := Address;
inherited Create(False);
end;
{ TUEAnalyzer }
procedure TUEAnalyzer.StartAnalyzer;
begin
FAnalyzerThread := TUEAnalyzerThread.Create(FAddress, FBatchDelay);
end;
function TUEAnalyzer.GetRunning: Boolean;
begin
Result := FAnalyzerThread <> nil;
end;
function TUEAnalyzer.GetAverageResponse: Extended;
begin
Result := FAnalyzerThread.AverageResponse;
end;
function TUEAnalyzer.GetDropedPackets: Cardinal;
begin
Result := FAnalyzerThread.DropedPackets;
end;
procedure TUEAnalyzer.StopAnalyzer;
begin
if Running then
begin
FAnalyzerThread.Terminate;
FAnalyzerThread := nil;
end;
end;
{ TUEClient }
constructor TUEClient.Create;
begin
FSocket := TUDPBlockSocket.Create;
end;
destructor TUEClient.Destroy;
begin
FreeAndNil(FSocket);
inherited Destroy;
end;
procedure TUEClient.Disconnect;
begin
FSocket.CloseSocket;
end;
function TUEClient.Connect(const Address: string): Boolean;
begin
FSocket.Connect(Address, '7');
Result := FSocket.LastError = 0;
end;
function TUEClient.SendEcho(const Message: string): string;
var
StartTime: TDateTime;
begin
Result := '';
StartTime := Now;
FSocket.SendString(Message);
if FSocket.LastError = 0 then
begin
Result := FSocket.RecvPacket(cReceiveTimeout);
FResponseTime := MilliSecondsBetween(Now, StartTime);
if FSocket.LastError <> 0 then
begin
FResponseTime := -1;
Result := '';
end;
end;
end;
end.
The code is written in free pascal, but works equally well in Delphi. The client unit is actually a line analyzer that calculates average response times and dropped packets. It is ideal to check the quality of your internet line to a certain server. You put the echo server to the server part and client on the client side.
Simple client-server in two program
client send two string "Hello world" and "exit"
server wait for client message and stop after client send "exit"
write on free pascal(Lazarus)
client
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
//ADD
blcksock;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string );
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var
sReason : String;
begin
case Reason of
HR_ResolvingBegin : sReason := 'HR_ResolvingBegin';
HR_ResolvingEnd : sReason := 'HR_ResolvingEnd';
HR_SocketCreate : sReason := 'HR_SocketCreate';
HR_SocketClose : sReason := 'HR_SocketClose';
HR_Bind : sReason := 'HR_Bind';
HR_Connect : sReason := 'HR_Connect';
HR_CanRead : sReason := 'HR_CanRead';
HR_CanWrite : sReason := 'HR_CanWrite';
HR_Listen : sReason := 'HR_Listen';
HR_Accept : sReason := 'HR_Accept';
HR_ReadCount : sReason := 'HR_ReadCount';
HR_WriteCount : sReason := 'HR_WriteCount';
HR_Wait : sReason := 'HR_Wait';
HR_Error : sReason := 'HR_Error';
end;
Memo1.Lines.Add( sReason + ': ' + Value );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
UDP: TUDPBlockSocket;
s:string;
begin
UDP := TUDPBlockSocket.Create;
try
UDP.OnStatus := #OnStatus;
//send to server
s:='Hello world from client';
UDP.Connect( '127.0.0.1', '12345' );
UDP.SendString('------'+s+'--------');
memo1.Append(s);
//for server stop send string "exit"
s:='exit';
UDP.SendString(s);
memo1.Append('---');
memo1.Append(s);
memo1.Append('---');
UDP.CloseSocket;
finally
UDP.Free;
end;
end;
end.
SERVER
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
//ADD
blcksock;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string );
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var
sReason : String;
begin
case Reason of
HR_ResolvingBegin : sReason := 'HR_ResolvingBegin';
HR_ResolvingEnd : sReason := 'HR_ResolvingEnd';
HR_SocketCreate : sReason := 'HR_SocketCreate';
HR_SocketClose : sReason := 'HR_SocketClose';
HR_Bind : sReason := 'HR_Bind';
HR_Connect : sReason := 'HR_Connect';
HR_CanRead : sReason := 'HR_CanRead';
HR_CanWrite : sReason := 'HR_CanWrite';
HR_Listen : sReason := 'HR_Listen';
HR_Accept : sReason := 'HR_Accept';
HR_ReadCount : sReason := 'HR_ReadCount';
HR_WriteCount : sReason := 'HR_WriteCount';
HR_Wait : sReason := 'HR_Wait';
HR_Error : sReason := 'HR_Error';
end;
Memo1.Append( sReason + ': ' + Value );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Sock:TUDPBlockSocket;
size:integer;
buf:string;
begin
Sock:=TUDPBlockSocket.Create;
try
//On status show error and other
//enable on status if you can more seen
//sock.OnStatus := #OnStatus;
sock.CreateSocket;
//create server
sock.bind('127.0.0.1','12345');
//send string to this server in this program(not client)
sock.Connect( '127.0.0.1', '12345' );
sock.SendString('test send string to sever');
if sock.LastError<>0 then exit;
//shutdown while client send "exit"
while buf<>'exit' do
begin
//get data client
buf := sock.RecvPacket(1000);
Memo1.Append(buf);
sleep(1);
end;
sock.CloseSocket;
finally
sock.free;
end;
end;
end.

What program lock the file

I need a program to overwrite the file, but sometimes some process is lock it. How to check which process locks a file, and how to unlock it? What functions should I use?
I found on the Internet such a code, but it doesn't work me.
unit proc;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ComCtrls, Grids, ValEdit, MTSUtilsUnit, TLHelp32,
Menus, PsAPI;
type
TApp = class
fPID: Integer;
fPArentPID: Integer;
fPIDName: string;
fThread: Integer;
fDLLName: TStringList;
fDLLPath: TStringList;
fDescription: string;
end;
TForm2 = class(TForm)
StatusBar1: TStatusBar;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Splitter2: TSplitter;
Edit1: TEdit;
Button1: TButton;
Label1: TLabel;
RichEdit1: TRichEdit;
PopupMenu1: TPopupMenu;
kill1: TMenuItem;
StringGrid1: TStringGrid;
function GetApps(AppName: string): TStringList;
function GetInfo(PID: Integer): string;
function Kill(PID: Integer): Boolean;
procedure kill1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
ApplicationList: TStringList;
row: Integer;
implementation
{$R *.dfm}
function TForm2.Kill(PID: Integer): Boolean;
var fHandle: THandle;
begin
fHandle := OpenProcess(PROCESS_TERMINATE, BOOL(0), PID);
if TerminateProcess(fHandle, 0) then
Result := True
else
Result := False;
CloseHandle(fHandle);
end;
procedure TForm2.kill1Click(Sender: TObject);
var i: Integer;
fApp: TApp;
begin
if Kill(StrToInt(StringGrid1.Cells[1, row])) then
begin
ApplicationList.Delete(row);
StringGrid1.RowCount := ApplicationList.Count;
for i := 1 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
Form2.StringGrid1.Cells[0,i] := fApp.fPIDName;
Form2.StringGrid1.Cells[1,i] := IntToStr(fApp.fPID);
end;
MessageBox(0, 'Terminate successfully', 'Kill', MB_ICONINFORMATION or MB_OK);
end
else
MessageBox(0, 'Could not terminate process', 'Kill', MB_ICONINFORMATION or MB_OK);
end;
procedure TForm2.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
var fApp: TApp;
begin
row := ARow;
RichEdit1.Lines.Clear();
if ApplicationList.Count >= row then
begin
fApp := TApp(ApplicationList.Objects[row]);
RichEdit1.Lines.Add(fApp.fDescription);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var i: Integer;
fApp: TApp;
sItem: string;
CanSelect: Boolean;
begin
for i := 0 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
FreeAndNil(fApp.fDLLName);
FreeAndNil(fApp.fDLLPath);
FreeAndNil(fApp);
end;
FreeAndNil(ApplicationList);
ApplicationList := GetApps(Edit1.Text);
StringGrid1.RowCount := ApplicationList.Count;
for i := 0 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
StringGrid1.Cells[0,i] := fApp.fPIDName;
StringGrid1.Cells[1,i] := IntToStr(fApp.fPID);
end;
StringGrid1.OnSelectCell(Self, 0, 1, CanSelect);
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0,0] := 'Name';
StringGrid1.Cells[1,0] := 'PID';
end;
function TForm2.GetInfo(PID: Integer): string;
var fHandle: THandle;
fModule: TModuleEntry32;
sInfo: string;
begin
Result := '';
sInfo := 'DLL Name: %s'#13#10 +
'DLL Path: %s'#13#10 +
'ModuleId: %d'#13#10;
fHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, PID);
if fHandle <> INVALID_HANDLE_VALUE then
if Module32First(fHandle, fModule) then
repeat
if SameText(ExtractFileExt(fModule.szModule), '.dll') then
begin
sInfo := Format(sInfo, [fModule.szModule, fModule.szExePath, fModule.th32ModuleID]);
Result := Result + sInfo;
end;
until not Module32Next(fHandle, fModule);
end;
function TForm2.GetApps(AppName: string): TStringList;
var fHandle: THandle;
fModHandle: THandle;
fProcess: TProcessEntry32;
fModule: TMODULEENTRY32;
App: TApp;
i: Integer;
IsDLL: Boolean;
IsProcess: Boolean;
fDesc: string;
sPath: string;
begin
IsDLL := False;
IsProcess := False;
Result := TStringList.Create();
Result.Clear();
fDesc := 'DLL Name: %s'#13#10 +
'DLL Path: %s'#13#10 +
'ModuleId: %d'#13#10;
fHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
fProcess.dwSize := SizeOf(fProcess);
IsProcess := Process32First(fHandle, fProcess);
while IsProcess do
begin
App := TApp.Create();
App.fDLLName := TStringList.Create();
App.fDLLPath := TStringList.Create();
fModHandle := CreateToolHelp32SnapShot(TH32CS_SNAPMODULE, fProcess.th32ProcessID);
IsDLL := Module32First(fModHandle, fModule);
while IsDLL do
begin
if Edit1.Text <> '' then
sPath := fModule.szModule
else
sPath := ExtractFileExt(fModule.szModule);
if SameText(sPath, Edit1.Text + '.dll') then
begin
App.fPID := fProcess.th32ProcessID;
App.fPIDName := fProcess.szExeFile;
App.fDLLName.Add(fModule.szModule);
App.fDLLPath.Add(fModule.szExePath);
App.fDescription := App.fDescription +
Format(fDesc, [fModule.szModule, fModule.szExePath, fModule.th32ModuleID]);
end;
IsDLL := Module32Next(fModHandle, fModule)
end;
if App.fDLLName.Count > 0 then
Result.AddObject(IntToStr(App.fPID), App);
IsProcess := Process32Next(fHandle, fProcess);
end;
CloseHandle(fHandle);
Result.Count;
end;
end.
You should not unlock the file yourself this will lead to lost data! Leave it to the user and instead show an error and explaining which process holds open the file.
This solution here will help you to do so:
http://www.remkoweijnen.nl/blog/2011/01/03/cannot-access-files-but-need-the-origin
Check out Process Explorer. It will show you which processes have which files opened, and will allow you to close individual files.

Resources