Delphi Pages Forums  

Go Back   Delphi Pages Forums > Delphi Forum > General

Lost Password?

Closed Thread
 
Thread Tools Display Modes
  #1  
Old 05-05-2016, 01:56 PM
FreakaZoid2 FreakaZoid2 is offline
Senior Member
 
Join Date: Jul 2009
Posts: 355
Default Threading: Correct/Incorrect handling.

I have this thread logic but to me it seems to take a LONG time to finish these tasks. I basically created a batch file that does the same thing and it seems to run a whole lot faster than my program does. I use this threading logic in several simple programs and I get the feeling that I have been using it incorrectly or something.

Code:
unit fMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.Buttons, Vcl.StdCtrls,
  Vcl.ExtCtrls, Utilities;

type
  TfrmMain = class(TForm)
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    LabeledEdit3: TLabeledEdit;
    SpeedButton3: TSpeedButton;
    StatusBar1: TStatusBar;
    sdlgMain: TSaveDialog;
    Button1: TButton;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    procedure ThreadDone(Sender: TObject);
    { Private declarations }
  public
    FRunningThreads       : integer;
    { Public declarations }
  end;

type
  TMyThread = class(TThread)
  private
    FVutil32,
    FVFile : string;
    FDOSOutput : TStringlist;
  public
    constructor Create(const Vutil32, VFile: string; DOSOutput: TStringlist; OnThreadDone: TNotifyEvent); reintroduce;
    destructor Destroy; override;
    procedure Execute; override;
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

function GetDosOutput(const ApptoRun : string; const CommandLine: string; sl: Tstrings): Boolean;
var
   SA: TSecurityAttributes;
   SI: TStartupInfo;
   PI: TProcessInformation;
   StdOutPipeRead, StdOutPipeWrite: THandle;
   WasOK: Boolean;
   Buffer: array[0..255] of AnsiChar;
   BytesRead: Cardinal;
   Line: String;
begin
   Application.ProcessMessages;
   with SA do
   begin
     nLength := SizeOf(SA);
     bInheritHandle := True;
     lpSecurityDescriptor := nil;
   end;
   Application.ProcessMessages;
   // create pipe for standard output redirection
   CreatePipe(StdOutPipeRead, // read handle
              StdOutPipeWrite, // write handle
              @SA, // security attributes
              0 // number of bytes reserved for pipe - 0 default
              );
   try
   Application.ProcessMessages;
     // Make child process use StdOutPipeWrite as standard out,
     // and make sure it does not show on screen.
     with SI do
     begin
       FillChar(SI, SizeOf(SI), 0);
       cb := SizeOf(SI);
       dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
       wShowWindow := SW_HIDE;
       hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect stdinput
       hStdOutput := StdOutPipeWrite;
       hStdError := StdOutPipeWrite;
     end;

     // launch the command line compiler
     //WorkDir := 'C:\';
   Application.ProcessMessages;
     result := CreateProcess(
       PChar(ApptoRun),
       PChar(CommandLine),
       nil,
       nil,
       True,
       0,
       nil,
       nil,  // PChar(Workdir),//'c:\'),
       SI,
       PI);

     // Now that the handle has been inherited, close write to be safe.
     // We don't want to read or write to it accidentally.
   Application.ProcessMessages;
     CloseHandle(StdOutPipeWrite);
     // if process could be created then handle its output
     if result then
       try
   Application.ProcessMessages;
         // get all output until dos app finishes
         Line := '';
         repeat
           // read block of characters (might contain carriage returns and line feeds)
           WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);

           // has anything been read?
           if BytesRead > 0 then
           begin
             // finish buffer to PChar
             Buffer[BytesRead] := #0;
             // combine the buffer with the rest of the last run
             Line := Line + Buffer;
             if (pos(#13,Line) > 0) then // and (trim(Line) <> '') then
             begin
               sl.Add(Line);
               Line := '';
             end;
           end;
         until not WasOK or (BytesRead = 0);
         // wait for console app to finish (should be already at this point)
         WaitForSingleObject(PI.hProcess, INFINITE);
       finally
         // Close all remaining handles
         CloseHandle(PI.hThread);
         CloseHandle(PI.hProcess);
       end;
   finally
   Application.ProcessMessages;
    // text := Line;
    sl.Add(Line);
     CloseHandle(StdOutPipeRead);
   end;
end;

procedure TMyThread.Execute;
begin
  FreeOnTerminate := true;
  GetDosOutput(FVutil32, FVFile, FDOSOutput);
end;

constructor TMyThread.Create(const Vutil32, VFile: string; DOSOutput: TStringlist; OnThreadDone: TNotifyEvent); //reintroduce;
begin
  inherited Create(True);
  FVutil32 := Vutil32;
  FVFile := VFile;
  FDOSOutput := DOSOutput;
  Onterminate := OnThreadDone;
//  FreeOnTerminate := true;
  Resume;
end;

destructor TMyThread.Destroy; //override;
begin
  inherited;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  Close;
end;

procedure TfrmMain.Button2Click(Sender: TObject);
var
  _tslist : Array of TStringlist;
  _oslist,
  _slist  : TStringlist;
  i,
  idx     : integer;
begin
  Application.ProcessMessages;
  _slist := TStringlist.Create;
  _slist.Clear;
  FindFiles(LabeledEdit2.Text, '*.', faDirectory, 0, false, _slist);
  SetLength(_tslist, _slist.Count);
  Button1.Enabled := False;
  Button2.Enabled := False;
  for idx := 0 to _slist.Count - 1 do
  begin
    _tslist[idx] := TStringlist.Create;
    _tslist[idx].Clear;
    TMyThread.Create(trim(LabeledEdit1.Text), ' -c -x -f ' + trim(_slist[idx]), _tslist[idx], ThreadDone);
    Inc(FRunningThreads);
    while (FRunningThreads > 999) do
    begin
      Sleep(1);
      Application.ProcessMessages;
    end;
  end;
  while FRunningThreads > 0 do
  begin
    Application.ProcessMessages;
    sleep(500);
  end;
  FreeAndNil(_slist);
  _oslist := TStringlist.Create;
  _oslist.Clear;
  for idx := Low(_tslist) to High(_tslist) - 1 do
  begin
    for I := 0 to _tslist[idx].Count - 1 do
    begin
      _oslist.Append(_tslist[idx][i]);
    end;
    FreeAndNil(_tslist[idx]);
  end;
  _oslist.SaveToFile(trim(LabeledEdit3.Text));
  FreeAndNil(_oslist);
  Button1.Enabled := True;
  Button2.Enabled := True;
end;

procedure TfrmMain.ThreadDone(Sender: TObject);
begin
  Dec(FRunningThreads);
end;

end.
  #2  
Old 05-05-2016, 03:57 PM
rojam rojam is offline
Senior Member
 
Join Date: Jun 2015
Posts: 198
Default

I refactored the code,so I may have made mistakes if I didn't fully understand what it was you were attempting.

A few comments I'll make, if you are running threads, you don't ever want to touch variables from both your thread and main app thread without synchronizing those calls. To facilitate that, I passed information to the thread that it needs to do it's work, and if needed it makes changes to its own local copy of the data rather than operating on the same data structures your main app is. I then give the main thread a way to get the output by using public functions within the thread that the main app can call when it gets notified that the thread finished.

To limit the number of threads created you should use a semaphore in combination with WaitForSingleObject. As coded your main app will still block when it is waiting, so the way out of that is to create yet another thread to launch each individual thread. That would make the 2nd thread block while waiting on a semaphore, not your main thread. But I wasn't going to add that much complexity.

You had several calls to Application.Processmessages within the code of GetDosOutput. GetDosOutput only runs in the context of your thread, so processmessages will do nothing for you.

Last point is that I made the changes in Notepad, not delphi (I don't have Delphi available at the moment)so I probably have several errors embedded in there. We can work them out as you find them. Also, I have no idea if this will speed up the process at all.
Code:
unit fMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.Buttons, Vcl.StdCtrls,
  Vcl.ExtCtrls, Utilities;

const
  MaxSemaphores = 20;//1000 seems a bit high for the number of threads running at one time.

type
  TfrmMain = class(TForm)
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    LabeledEdit3: TLabeledEdit;
    SpeedButton3: TSpeedButton;
    StatusBar1: TStatusBar;
    sdlgMain: TSaveDialog;
    Button1: TButton;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    ThreadsFinished: Integer;
    _slist: TStringlist;
    _tslist: Array of TStringlist;
    procedure ThreadDone(Sender: TObject);
    proecedure ClearArray;
    procedure LaunchThreads(const aUtil32: String; aVFileList: TStringList);
  public
    { Public declarations }
  end;

  TMyThread = class(TThread)
  private
    FVutil32,
    FVFile : String;
    FDOSOutputIndex: Integer;
    OutputSL: TStringList;
    function GetDosOutput(const ApptoRun, CommandLine: String; SL: TStrings): Boolean;
  public
    constructor Create(const aVutil32, aVFile: string; aDOSOutputIndex: Integer); reintroduce;
    destructor Destroy; override;
    procedure Execute; override;
    function GetOutputSL: TStringList;
    function GetOuputIndex: Integer;
  end;

var
  frmMain: TfrmMain;
  Sem: THandle;

implementation

{$R *.dfm}

procedure TfrmMain.ClearArray;
var
   Idx: Integer;
begin
  for Idx := Low(_tslist) to High(_tslist) do
    FreeAndNil(_tslist[Idx]);
  SetLength(_tslist, 0);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  _slist := TStringlist.Create;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  _slist.Free;
  ClearArray;
end;

procedure TfrmMain.ThreadDone(Sender: TObject);
var
  ListIndexToFill: Integer;
  _oslist: TStringList;
begin
  ListIndexToFill := (Sender as TMyThread).GetOutputIndex;
  _slist[ListIndexToFill].Assign((Sender as TMyThread).GetOutputSL);
  Inc(ThreadsFinished);

  if ThreadsFished = _slist.Count then
  begin
    _oslist := TStringlist.Create;
    try
      for idx := Low(_tslist) to High(_tslist) do
        _oslist.AddStrings(_tslist[idx]);
      _oslist.SaveToFile(trim(LabeledEdit3.Text));
    finally
      _oslist.Free;
    end;
    Button1.Enabled := True;
    Button2.Enabled := True;
  end;
end;

procedure TfrmMain.Button2Click(Sender: TObject);
begin
  Button1.Enabled := False;
  Button2.Enabled := False;
  _slist.Clear;

  //don't know what this does, so I assume it is a procedure you wrote but didn't include
  FindFiles(LabeledEdit2.Text, '*.', faDirectory, 0, false, _slist);
  //////

  LaunchThreads(trim(LabeledEdit1.Text) + ' -c -x -f ', _slist);
end;

procedure TfrmMain.LaunchThreads(const aUtil32: String; aVFileList: TStringList);
var
  idx: integer;
  WaitResult: Integer;
begin
  ThreadsFinished := 0;
  ClearArray;
  SetLength(_tslist, aVFileList.Count);
  for idx := Low(_slist) to High(_slist) do
  begin
    WaitResult := WaitForSingleObject(Sem, INFINITE);
    if WaitResult = WAIT_OBJECT_0 then
    begin
      _tslist[idx] := TStringlist.Create;
      with TMyThread.Create(aUtil32, aVFileList[idx], idx) do
      begin
        OnTerminate := ThreadDone;
        FreeOnTerminate := True;
        Start;
      end;      
    end;
  end;
end;

//*******Thread Code***********
procedure TMyThread.Execute;
begin
  try
    GetDosOutput(FVutil32, FVFile, OutputSL);
  finally
    ReleaseSemaphore(Sem, 1, nil);
  end;
end;

constructor TMyThread.Create(const aVutil32, aVFile: string; aDOSOutputIndex: Integer);
begin
  inherited Create(True);
  OutputSL := TStringList.Create;
  FVutil32 := aVutil32;
  FVFile := aVFile;
  FDOSOutputIndex := aDOSOutputIndex;
end;

function TMyThread.GetOutputIndex: Integer;
begin
  Result := FDOSOuputIndex;
end;

function TMyThread.GetOutputSL: TStringList;
begin
  Result := OutpuSL;
end;

destructor TMyThread.Destroy;
begin
  OutputSL.Free;
  inherited;
end;

function TMyThread.GetDosOutput(const ApptoRun, CommandLine: String; SL: TStrings): Boolean;
var
   SA: TSecurityAttributes;
   SI: TStartupInfo;
   PI: TProcessInformation;
   StdOutPipeRead, StdOutPipeWrite: THandle;
   WasOK: Boolean;
   Buffer: array[0..255] of AnsiChar;
   BytesRead: Cardinal;
   Line: String;
begin
  //Never ever call Application.ProcessMessages from a Thread!!!!!
  //Only your main application thread should be checking for Messages
  //Unless you set up a message loop within your thread
  //which you have NOT done


   //Application.ProcessMessages;
   with SA do
   begin
     nLength := SizeOf(SA);
     bInheritHandle := True;
     lpSecurityDescriptor := nil;
   end;
   //Application.ProcessMessages;
   // create pipe for standard output redirection
   CreatePipe(StdOutPipeRead, // read handle
              StdOutPipeWrite, // write handle
              @SA, // security attributes
              0 // number of bytes reserved for pipe - 0 default
              );
   try
   //Application.ProcessMessages;
     // Make child process use StdOutPipeWrite as standard out,
     // and make sure it does not show on screen.
     with SI do
     begin
       FillChar(SI, SizeOf(SI), 0);
       cb := SizeOf(SI);
       dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
       wShowWindow := SW_HIDE;
       hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect stdinput
       hStdOutput := StdOutPipeWrite;
       hStdError := StdOutPipeWrite;
     end;

     // launch the command line compiler
     //WorkDir := 'C:\';
   //Application.ProcessMessages;
     result := CreateProcess(
       PChar(ApptoRun),
       PChar(CommandLine),
       nil,
       nil,
       True,
       0,
       nil,
       nil,  // PChar(Workdir),//'c:\'),
       SI,
       PI);
     // Now that the handle has been inherited, close write to be safe.
     // We don't want to read or write to it accidentally.
   //Application.ProcessMessages;
     CloseHandle(StdOutPipeWrite);
     // if process could be created then handle its output
     if result then
       try
   //Application.ProcessMessages;
         // get all output until dos app finishes
         Line := '';
         repeat
           // read block of characters (might contain carriage returns and line feeds)
           WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);

           // has anything been read?
           if BytesRead > 0 then
           begin
             // finish buffer to PChar
             Buffer[BytesRead] := #0;
             // combine the buffer with the rest of the last run
             Line := Line + Buffer;
             if (pos(#13,Line) > 0) then // and (trim(Line) <> '') then
             begin
               SL.Add(Line);
               Line := '';
             end;
           end;
         until not WasOK or (BytesRead = 0);
         // wait for console app to finish (should be already at this point)
         WaitForSingleObject(PI.hProcess, INFINITE);
       finally
         // Close all remaining handles
         CloseHandle(PI.hThread);
         CloseHandle(PI.hProcess);
       end;
   finally
   //Application.ProcessMessages;
    // text := Line;
     SL.Add(Line);
     CloseHandle(StdOutPipeRead);
   end;
end;
//********Thread Code**********
initialization
  Sem := CreateSemaphore(nil, MaxSemaphores, MaxSemaphores, '');
finalization
  CloseHandle(Sem);
end.

Last edited by rojam; 05-05-2016 at 04:18 PM.
  #3  
Old 05-05-2016, 07:17 PM
FreakaZoid2 FreakaZoid2 is offline
Senior Member
 
Join Date: Jul 2009
Posts: 355
Default question about logic and if i should even be using thread

Basically VUTIL32.exe is a program that we use to test the integrity of files in a select folder.
So in theory you could create a batch file like this
Code:
start c:\vutil32.exe -c -x -f c:\myfiles\file1
start c:\vutil32.exe -c -x -f c:\myfiles\file2
....
start c:\vutil32.exe -c -x -f c:\myfiles\file2873
I am using the getdosoutput because i need the results from each line to inform the user if they file might have problems.
Should i use a different approach to accomplish this (just use getdosoutput directly somehow)
I really dont care that the user can't do anything with the main form/window until it is done. After posting code i changed it to disable all the controls until after it was finished. I have been experimenting with the number of threads to spawn so i do have a throttle value now of 50.
  #4  
Old 05-05-2016, 08:45 PM
FreakaZoid2 FreakaZoid2 is offline
Senior Member
 
Join Date: Jul 2009
Posts: 355
Default

actually your suggestion of removing the application.processmessages from the getdosoutput got me the speed and what i wanted. around 50 threads running.

Thanks a million.
Closed Thread

Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is On

Forum Jump


All times are GMT. The time now is 07:12 AM.


Powered by vBulletin® Version 3.8.8
Copyright ©2000 - 2019, vBulletin Solutions, Inc.