Ramsay
12-04-2016, 20:48:35
Hola , estoy haciendo una unit que hace multithreading , el codigo de la unit :
unit probando;
{$POINTERMATH ON}
interface
uses
System.SysUtils, Vcl.Dialogs, Windows, TlHelp32, ShellApi,
Classes, Math, Vcl.Forms, Vcl.Imaging.jpeg, Vcl.StdCtrls, Vcl.Graphics,
Vcl.Controls,
ComObj, ActiveX, Variants, Messages;
type
T_probando = class
private
public
constructor Create;
destructor Destroy; override;
function loader_tester(argument: string; count: integer): string;
end;
implementation
constructor T_probando.Create;
begin
inherited Create;
//
end;
destructor T_probando.Destroy;
begin
inherited Destroy;
end;
// Function loader_tester
type
thread_loader_tester = class(TThread)
protected
procedure Execute; override;
public
argument: string;
end;
procedure thread_loader_tester.Execute;
var
command: string;
info: string;
begin
TThread.Synchronize(nil,
procedure
begin
command := 'c:/xampp/titulo.txt';
info := '';
ShellExecute(0, 'open', Pchar(command), Pchar(info), nil, SW_NORMAL);
end);
end;
function T_probando.loader_tester(argument: string; count: integer): string;
var
thread_now: thread_loader_tester;
i: integer;
fThreadRefCount: integer;
check: integer;
begin
try
fThreadRefCount := 0;
begin
For i := 1 to count do
begin
thread_now := thread_loader_tester.Create(True);
thread_now.argument := argument;
thread_now.FreeOnTerminate := True;
thread_now.Start;
Inc(fThreadRefCount);
end;
While fThreadRefCount > 1 do
// While (fThreadRefCount > 1) and (fThreadRefCount < count) do
begin
Application.ProcessMessages;
CheckSynchronize;
end;
Result := 'ok';
end;
Result := 'ok';
except
begin
Result := 'error';
end;
end;
end;
end.
Debe funcionar tanto en aplicaciones graficas como en consola , lamentablemente estoy mejorandola para que funcione en consolas , el codigo de la consola.
program test;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows, System.SysUtils, probando;
var
test_now: T_probando;
begin
try
test_now := T_probando.Create();
Writeln('[+] Response');
Writeln('response : '+test_now.loader_tester('c:/xampp/titulo.txt', 5));
Readln;
except
on E: Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
Funciona , pero entra en un ciclo infinito :
While fThreadRefCount > 1 do
Intente checkeando que verificara la cantidad de threads y ahi terminara :
While (fThreadRefCount > 1) and (fThreadRefCount < count) do
Pero si hago esto no se ejecuta ningun thread.
:eek::eek::eek:
¿ Alguien podria ayudarme ?
unit probando;
{$POINTERMATH ON}
interface
uses
System.SysUtils, Vcl.Dialogs, Windows, TlHelp32, ShellApi,
Classes, Math, Vcl.Forms, Vcl.Imaging.jpeg, Vcl.StdCtrls, Vcl.Graphics,
Vcl.Controls,
ComObj, ActiveX, Variants, Messages;
type
T_probando = class
private
public
constructor Create;
destructor Destroy; override;
function loader_tester(argument: string; count: integer): string;
end;
implementation
constructor T_probando.Create;
begin
inherited Create;
//
end;
destructor T_probando.Destroy;
begin
inherited Destroy;
end;
// Function loader_tester
type
thread_loader_tester = class(TThread)
protected
procedure Execute; override;
public
argument: string;
end;
procedure thread_loader_tester.Execute;
var
command: string;
info: string;
begin
TThread.Synchronize(nil,
procedure
begin
command := 'c:/xampp/titulo.txt';
info := '';
ShellExecute(0, 'open', Pchar(command), Pchar(info), nil, SW_NORMAL);
end);
end;
function T_probando.loader_tester(argument: string; count: integer): string;
var
thread_now: thread_loader_tester;
i: integer;
fThreadRefCount: integer;
check: integer;
begin
try
fThreadRefCount := 0;
begin
For i := 1 to count do
begin
thread_now := thread_loader_tester.Create(True);
thread_now.argument := argument;
thread_now.FreeOnTerminate := True;
thread_now.Start;
Inc(fThreadRefCount);
end;
While fThreadRefCount > 1 do
// While (fThreadRefCount > 1) and (fThreadRefCount < count) do
begin
Application.ProcessMessages;
CheckSynchronize;
end;
Result := 'ok';
end;
Result := 'ok';
except
begin
Result := 'error';
end;
end;
end;
end.
Debe funcionar tanto en aplicaciones graficas como en consola , lamentablemente estoy mejorandola para que funcione en consolas , el codigo de la consola.
program test;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows, System.SysUtils, probando;
var
test_now: T_probando;
begin
try
test_now := T_probando.Create();
Writeln('[+] Response');
Writeln('response : '+test_now.loader_tester('c:/xampp/titulo.txt', 5));
Readln;
except
on E: Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
Funciona , pero entra en un ciclo infinito :
While fThreadRefCount > 1 do
Intente checkeando que verificara la cantidad de threads y ahi terminara :
While (fThreadRefCount > 1) and (fThreadRefCount < count) do
Pero si hago esto no se ejecuta ningun thread.
:eek::eek::eek:
¿ Alguien podria ayudarme ?