Commande DOS affichée dans memo, le tout dans un thread

**LaurentC33** · 04/10/2013, 10h00

Bonjour à tous,

J'ai besoin pour mon appli de commander un api utilisable uniquement en DOS.
Pour cela j'essayer de créer une classe avec comme argument du constructeur mon Tmemo, et ensuite a chaque fois que j'appelle ma méthode add( commande ), automatiquement ça ajoute la commande au thread en cours.
Déjà, est ce que c'est bien utile que je passe ça dans un thread ? J'ai fait cela pour des commandes qui renvoie plusieurs lignes avec un certain délais.
Je patoge

J'ai récupéré du code pour la gestion de la commande dos, mais ce que j'aimerais c'est rester dans la même session de commande, et non a chaque commande avoir une nouvelle session.
Est ce possible ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
unit DosCommandUnit;
 
{
  Classe qui execute des commandes DOS dans un thread, visible dans un TMemo
 
  Ex :
 
  dosCommand := TDosCommand.Create(memo);
  dosCommand.add('cd C:\Apps');
  dosCommand.add('dir');
}
interface
uses Vcl.StdCtrls, Windows, System.Classes, Forms, Vcl.ComCtrls;
 
type
 
 
TThreadDosCommand = class(TThread)
  private
    commandLine: string;
    memo: TMemo;
    function add(CommandLine: string): string;
  protected
    procedure Execute; override;
  end;
 
TDosCommand = class
   private
      threadDC: TThreadDosCommand;
   public
      Constructor Create(memo: TMemo);
      procedure add(commandLine: string);
   end;
 
 
 
implementation
 
 
{ TThreadDosCommand }
function TThreadDosCommand.add(commandLine: string): string;
begin
  Self.commandLine := commandLine;
end;
 
procedure TThreadDosCommand.Execute;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of AnsiChar;
  BytesRead: Cardinal;
  WorkDir: string;
  Handle: Boolean;
begin
  inherited;
 
  with SA do begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;
  CreatePipe(StdOutPipeRead, StdOutPipeWrite, @SA, 0);
  try
    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 stdin
      hStdOutput := StdOutPipeWrite;
      hStdError := StdOutPipeWrite;
    end;
    WorkDir := 'C:\';
    Handle := CreateProcess(nil, PChar('cmd.exe /C ' + CommandLine),
                            nil, nil, True, 0, nil,
                            PChar(WorkDir), SI, PI);
    CloseHandle(StdOutPipeWrite);
    if Handle then
      try
        repeat
          WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
          if BytesRead > 0 then
          begin
            Buffer[BytesRead] := #0;
            memo.Text := memo.Text + Buffer;
          end;
        until not WasOK or (BytesRead = 0);
        WaitForSingleObject(PI.hProcess, INFINITE);
      finally
        CloseHandle(PI.hThread);
        CloseHandle(PI.hProcess);
      end;
  finally
    CloseHandle(StdOutPipeRead);
  end;
end;
 
{ TDosCommand }
constructor TDosCommand.Create(memo: TMemo);
begin
  threadDC := TThreadDosCommand.Create(False);
  threadDC.memo := memo;
end;
 
procedure TDosCommand.add(CommandLine: string);
begin
  threadDC.add(CommandLine);
end;
 
end.

**ShaiLeTroll** · 04/10/2013, 12h13

J'ai écrit ceci pour lancer des script PHP écrivant dans la console

Essaye d'avoir un code fonctionnel même sans thread !
Comme tu lances un processus parallèle, tu n'a pas besoin de thread pour écouter les Pipes

A mon avis, ton WaitForSingleObject en INFINITE n'est pas approprié pour un fil de l'eau en temps réel
Tu boucles trop sur ReadFile, laisse le processus travaillé un peu !

tu peux réutiliser mon code, il doit supporter les threads !
La seule chose à corriger serait que _ExportEvent utilise un TThread.Synchronize pour éviter de modifier un Memo depuis un Thread ce qui n'est pas prudent !

**LaurentC33** · 04/10/2013, 14h06

Merci Shai une fois de plus

Je vais tester ça !

**ShaiLeTroll** · 04/10/2013, 17h12

Sinon, pour ton histoire de session DOS, je n'avais pas vu ça !

Deux approches :
- Générer un .BAT qui s'auto-supprime en fin de script
- Gérer le ProcessID fourni par CreateProcess et lors de l'execution suivante, utiliser le Input pour envoyer la seconde commande

**LaurentC33** · 08/10/2013, 12h04

Bonjour Shai.
Laisse tomber l'histoire de session DOS, ce n'est plus necessaire.
J'ai essayé ton code, mais assez complexe

J'ai trouvé cela par contre :
http://thundaxsoftware.blogspot.fr/2...1_archive.html

J'ai trouvé cette procédure superbe, car elle utilise des callback (ce que je ne savais pas possible en delphi jusqu'à maintenant ).
Ca marche nickel, je l'ai un peu adapté à ma sauce :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
 
unit DosCommandUnit;
 
 
interface
uses Vcl.StdCtrls, Windows, System.Classes, Forms, Vcl.ComCtrls;
 
type
    TArg<T> = reference to procedure(const Arg: T);
 
    ConsoleOutput = class
      private
        stopCapture: boolean;
        piProcess: TProcessInformation;
      public
        procedure Capture(const ACommand: String; CallBackRunTime, CallBackTerminate: TArg<PAnsiChar>; waitTimeout: integer = WAIT_TIMEOUT);
        procedure Stop;
    end;
 
implementation
 
{ ConsoleOutput }
 
procedure ConsoleOutput.Capture(const ACommand: String; CallBackRunTime, CallBackTerminate: TArg<PAnsiChar>; waitTimeout: integer = WAIT_TIMEOUT);
const
  CReadBuffer = 2400;
var
  saSecurity: TSecurityAttributes;
  hRead: THandle;
  hWrite: THandle;
  suiStartup: TStartupInfo;
  pBuffer: array [0 .. CReadBuffer] of AnsiChar;
  dBuffer: array [0 .. CReadBuffer] of AnsiChar;
  dRead: DWORD;
  dRunning: DWORD;
  dAvailable: DWORD;
begin
  stopCapture := false;
  saSecurity.nLength := SizeOf(TSecurityAttributes);
  saSecurity.bInheritHandle := true;
  saSecurity.lpSecurityDescriptor := nil;
  if CreatePipe(hRead, hWrite, @saSecurity, 0) then
    try
      FillChar(suiStartup, SizeOf(TStartupInfo), #0);
      suiStartup.cb := SizeOf(TStartupInfo);
      suiStartup.hStdInput := hRead;
      suiStartup.hStdOutput := hWrite;
      suiStartup.hStdError := hWrite;
      suiStartup.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      suiStartup.wShowWindow := SW_HIDE;
      if CreateProcess(nil,PChar('cmd.exe /C ' + ACommand), @saSecurity, @saSecurity, true, NORMAL_PRIORITY_CLASS, nil, nil, suiStartup,
        piProcess) then
        try
          repeat
            dRunning := WaitForSingleObject(piProcess.hProcess, 100);
            PeekNamedPipe(hRead, nil, 0, nil, @dAvailable, nil);
            if (dAvailable > 0) then
              repeat
                dRead := 0;
                ReadFile(hRead, pBuffer[0], CReadBuffer, dRead, nil);
                pBuffer[dRead] := #0;
                OemToCharA(pBuffer, dBuffer);
                CallBackRunTime(dBuffer);
              until (dRead < CReadBuffer) OR (stopCapture = true);
            Application.ProcessMessages;
          until (dRunning <> waitTimeout) OR (stopCapture = true);
        finally
          CloseHandle( piProcess.hProcess );
          CloseHandle( piProcess.hThread );
        end;
    finally
      CloseHandle(hRead);
      CloseHandle(hWrite);
      CallBackTerminate(nil);
    end;
end;
 
 
procedure ConsoleOutput.Stop;
begin
  stopCapture := true;
end;
 
end.

Par contre j'ai deux problèmes.
Si on ferme l'application, même en passant par la méthode Stop, j'ai des processus cmd.exe qui restent actifs.
Pas hyper important dans l'immédiat, mais il faut que je modifie ma classe pour que tous les process soit supprimés en cas de fermeture de l'appli. Peux être stocker chaque TProcessInformation dans une variable "statique" afin de les fermer tous.

Truc plus important : Dans la méthode Capture, j'ai un paramètre waitTimeout. J'ai fait ceci afin de pouvoir avoir un appel de Capture qui ne ce ferme pas en cas de commande (ACommand) qui ne renvois pas d'infos depuis un délais conséquent. Mais ça ne marche pas...Ca ferme quand même, avec n'importe quelle valeur de waitTimeout

**LaurentC33** · 08/10/2013, 17h12

Nouvelle version mais rien de mieux

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
 
unit DosCommandUnit;
 
 
interface
uses Vcl.StdCtrls, Windows, System.Classes, Forms, Vcl.ComCtrls;
 
type
    TArg<T> = reference to procedure(const Arg: T);
 
    ConsoleOutputThread = class( TThread )
      private
 
      protected
        procedure Execute;  override;
      public
        ACommand: string;
        CallBackRunTime, CallBackTerminate: TArg<String>;
    end;
 
 
    function startConsole(_ACommand: String; _CallBackRunTime, _CallBackTerminate: TArg<String>) : ConsoleOutputThread;
    procedure stopConsole(OutputThreadHandle  : ConsoleOutputThread);
 
implementation
 
{ ConsoleOutput }
procedure ConsoleOutputThread.Execute;
const
  CReadBuffer = 2400;
var
  saSecurity: TSecurityAttributes;
  hRead: THandle;
  hWrite: THandle;
  suiStartup: TStartupInfo;
  piProcess: TProcessInformation;
  pBuffer: array [0 .. CReadBuffer] of AnsiChar;
  dBuffer: array [0 .. CReadBuffer] of AnsiChar;
  dRead: DWORD;
  dRunning: DWORD;
  dAvailable: DWORD;
begin
  saSecurity.nLength := SizeOf(TSecurityAttributes);
  saSecurity.bInheritHandle := true;
  saSecurity.lpSecurityDescriptor := nil;
  if CreatePipe(hRead, hWrite, @saSecurity, 0) then
    try
      FillChar(suiStartup, SizeOf(TStartupInfo), #0);
      suiStartup.cb           := SizeOf(TStartupInfo);
      suiStartup.hStdInput    := hRead;
      suiStartup.hStdOutput   := hWrite;
      suiStartup.hStdError    := hWrite;
      suiStartup.dwFlags      := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      suiStartup.wShowWindow  := SW_HIDE;
 
      if CreateProcessW(
          nil,
          PChar('cmd.exe /C ' + ACommand),
          @saSecurity,
          @saSecurity,
          true,
          NORMAL_PRIORITY_CLASS,
          nil,
          nil,
          suiStartup,
      piProcess) then
        try
          repeat
            dRunning := WaitForSingleObject(piProcess.hProcess, 100);
            PeekNamedPipe(hRead, nil, 0, nil, @dAvailable, nil);
            if (dAvailable > 0) then
              repeat
                dRead := 0;
                ReadFile(hRead, pBuffer[0], CReadBuffer, dRead, nil);
                pBuffer[dRead] := #0;
                OemToCharA(pBuffer, dBuffer);
                CallBackRunTime(dBuffer);
              until dRead < CReadBuffer;
            Application.ProcessMessages;
          until dRunning <> WAIT_TIMEOUT;
        finally
          CloseHandle( piProcess.hProcess );
          CloseHandle( piProcess.hThread );
        end;
 
    finally
      CloseHandle(hRead);
      CloseHandle(hWrite);
      CallBackTerminate('');
    end;
end;
 
 
function startConsole(_ACommand: String; _CallBackRunTime, _CallBackTerminate: TArg<String>) : ConsoleOutputThread;
var
    consoleOThrd: ConsoleOutputThread;
begin
    consoleOThrd := ConsoleOutputThread.Create(true);
 
    with consoleOThrd do begin
      ACommand := _ACommand;
      CallBackRunTime := _CallBackRunTime;
      CallBackTerminate := _CallBackTerminate;
      FreeOnTerminate := TRUE;
      Resume;
    end;
 
    Result := consoleOThrd;
end;
 
 
procedure stopConsole(OutputThreadHandle  : ConsoleOutputThread);
begin
     OutputThreadHandle.Terminate;
     while not(OutputThreadHandle.Terminated) do sleep (100);
end;
 
 
end.

**LaurentC33** · 08/10/2013, 17h37

Il faut que je rajoute un SendMessage dans la méthode stopConsole, pour fermer le cmd.exe.
Donc il faut que je récupère le Handle à partir de CreateProcessW, mais je coince un peu ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
procedure stopConsole(OutputThreadHandle  : ConsoleOutputThread);
begin
     OutputThreadHandle.Terminate;
     while not(OutputThreadHandle.Terminated) do sleep (100);
end;

**ShaiLeTroll** · 08/10/2013, 17h49

Envoyé par LaurentC33

J'ai trouvé cette procédure superbe, car elle utilise des callback (ce que je ne savais pas possible en delphi jusqu'à maintenant ).

En fait, a peu de chose, si l'on retire les génériques, c'est la même chose que mon code !
Et des CallBack, c'est juste une technique d'appel de procédure, sans t'en rendre compte, tu en utilises tout le temps, tout Event Delphi est un CallBack

Dans mon code, c'est TCallCmdEvent qui est en fait le CallBack

Sinon, la gestion des Pipes dans ce code de Lübbe Onken et Lars Fosdal ressemble à l'erreur classique d'utiliser le même Pipe pour hStdInput et hStdOutput, je l'ai aussi faite avant de reprendre l'exemple de la MSDN Comment faire pour le déploiement de processus de console avec des poignées standard redirigées

Mon code est aussi plus long car il inclu justement le TerminateProcess pour gérer le cas du Abort qui résoudra ton problème de processus qui traine !

Pour le TimeOut, je n'ai compris ton code !

WAIT_TIMEOUT est une valeur retourné quand WaitForSingleObject relache son attente (dans ton cas 100ms)
Comme on surveille un processus, WAIT_TIMEOUT sera la valeur que l'on obtiendra à 99.99% du temps
Lorsque le processus est terminé cela renverra un WAIT_OBJECT_0
Les autres valeurs sont testé dans mon code pour prévoir d'eventuelles erreurs

**LaurentC33** · 08/10/2013, 18h01

Merci pour ces précisions

Je vais utiliser ta méthode. Merci de prendre du temps pour m'expliquer tout cela, je ne suis pas un grand guerrier sous delphi (ça fait juste 3 mois

)

**ShaiLeTroll** · 08/10/2013, 18h17

Finalement j'ai compris ton timeout !
Tu veux gérer "le plantage" de l'application lancée qui ne répond plus !

Je dirais qu'il faut le faire uniquement en cas WAIT_TIMEOUT qui veut juste dire que ton processus existe toujours !

Je n'ai pas testé mais j'ai ajouté un TimeOut
Attention ne pas confondre avec Delay !

Delay c'est l'attente entre deux cycles de lecture, dans ton code, il est fixé à 100 millisecondes
TimeOut c'est l'attente limite si il y absence de données !

c'est un code Delphi 7
J'ai remplacé certains Cardinal par des THandle pour les compilateurs 64 Bits comme XE2

Appel qui devrait passé avec ton TThreadDosCommand avec 100ms comme délai de refresh et 10sec (10 000ms) comme temps maximal en cas de plantage

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 
procedure _TThreadDosCommandWaitEvent(Parent: Cardinal; const Output, Error: string; var AbortProcess: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).WaitEvent(Output, Error, AbortProcess);
  end;
end;
 
procedure TThreadDosCommand.Execute();
var
  ExitCode: Int64;
  OutputText: string; 
  ErrorText: string;
begin
  CallCmd('', 'cmd.exe', '/C cd ........', ExitCode, OutputText, ErrorText, 100,  Self, _TThreadDosCommandWaitEvent, 0, 10000);
  (*
  Ici peu importe le traitement de WaitEvent
  OutputText contient TOUT le retour de la console
  ErrorText contient les messages d'erreur, c'est rarissime !
*)
end;
 
 
 
procedure TThreadDosCommand.WaitEvent(const Output, Error: string; var AbortProcess: Boolean);
begin
 (* 
  Ici tu peux récupérer Output 
  Cela contient juste la dernière lecture
  Attention n'utilise pas de TMemo en TThread sans Synchronize !
*)
end;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
 
interface
 
uses Windows, SysUtils;
 
{* -----------------------------------------------------------------------------
TCallCmdEvent pointeur de procédure ...
@param Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
@param Output contiennent les derniers éléments envoyés par le programme console sur le canal StdOut
@param Error contiennent les derniers éléments envoyés par le programme console sur le canal StdError
@param AbortProcess indique si la processus doit être arrêté
------------------------------------------------------------------------------ }
type
  TCallCmdEvent = procedure(Parent: Cardinal; const Output, Error: string; var AbortProcess: Boolean); stdcall;
 
function CallCmd(const CmdDirectory, CmdName, CmdParam: string; out ExitCode: Int64; out OutputText: string; out ErrorText: string; Delay: Cardinal = INFINITE; Parent: Cardinal = 0; WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0; TimeOut: Cardinal = 0): Boolean;
 
implementation
 
uses Math;
 
{* -----------------------------------------------------------------------------
la fonction CallCmd permet de lancer un programme console, tout en récupérant en quasi temps-réel le contenu devant normalement s'y afficher
@param CmdDirectory Dossier contenant le Fichier CmdName
@param CmdName programme console à executer
@param CmdParam paramètres de la ligne de commande
@param ExitCode Code de Sortie renvoyé par le programme console, -1 si non récupéré
@param OutputText chaine contenant tout ce qui aurait du s'afficher (canal sortie)
@param ErrorText chaine contenant tout ce qui a été signalé comme erreurs (canal erreur)
@param Delay indique le temps entre chaque cycle de lecture des canaux, détermine la fréquence de lancement de WaitEvent, par défaut, cela attend que le programme console se termine
@param Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
@param WaitEvent procédure à lancer lorsque le Delay est écoulé, Output et Error contiennent les derniers éléments envoyés par le programme console sur les canaux depuis le dernier délai, AbortProcess indique si la processus doit être arrêté
@param PipeMaxSize défini la taille maximal que l'on lit à chaque chaque cycle de lecture des canaux, si zéro, taille non limitée par défaut
@param TimeOut défini le temps d'attente maximal en cas d'absence de données dans les canaux, si zéro, temps non limité par défaut
@return Indique si le programme a été lancé
------------------------------------------------------------------------------ }
function CallCmd(const CmdDirectory, CmdName, CmdParam: string; out ExitCode: Int64; out OutputText: string; out ErrorText: string; Delay: Cardinal = INFINITE; Parent: Cardinal = 0; WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0; TimeOut: Cardinal = 0): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  CmdLine: string; // utile pour le débogage
  SecurityAttr : TSecurityAttributes;
  hReadPipeInput, hWritePipeInput: THandle;
  hReadPipeOutput, hWritePipeOutput: THandle;
  hReadPipeError, hWritePipeError: THandle;
  Terminated: Boolean;
  AbortProcess: Boolean;
  HandleFunctionProcess: Cardinal;
  ReadTick: Cardinal;
  CurrentTick: Cardinal;
 
  function ReadPipe(Handle: Cardinal; out Buf: string): Boolean;
  const
    MAX_INT: Cardinal = MaxInt;
  var
    PipeSize: Cardinal;
    PipeToRead, PipeReaded: Cardinal;
  begin
    PipeSize := GetFileSize(Handle, nil); // On oublie si cela dépasse 2Go ... normalement c'est 4Ko
    if (PipeMaxSize > 0) and (PipeSize > PipeMaxSize) then
      PipeToRead := PipeMaxSize
    else
      PipeToRead := PipeSize;
 
    Result := PipeToRead > 0;
    if Result then
    begin
      SetLength(Buf, PipeToRead);
      ZeroMemory(@Buf[1], PipeToRead);
      ReadFile(Handle, Buf[1], PipeToRead, PipeReaded, nil);
      ReadTick := GetTickCount();
    end;
  end;
 
  procedure ReadPipes();
  var
    DeltaOutputText: string;
    DeltaErrorText: string;
  begin
    if ReadPipe(hReadPipeOutput, DeltaOutputText) then
      OutputText := OutputText + DeltaOutputText;
    if ReadPipe(hReadPipeError, DeltaErrorText) then
      ErrorText := ErrorText + DeltaErrorText;
    try
      if Assigned(WaitEvent) then
        WaitEvent(Parent, DeltaOutputText, DeltaErrorText, AbortProcess);
    except
      on E: Exception do
        OutputDebugString(PChar(Format('epcWindows.CallCmd.ReadPipes.WaitEvent - "%s" : "%s"', [E.ClassName, E.Message])));
    end;
  end;
 
begin
  (*
  Result := True;
  OutputText := 'Dummy Output';
  ErrorText := 'Dummy Error';
  ErrorCode := 0;
  Exit;
  *)
  OutputText := '';
  ErrorText := '';
  try
    SecurityAttr.nLength := SizeOf(TSecurityAttributes);
    SecurityAttr.lpSecurityDescriptor := nil;
    SecurityAttr.bInheritHandle := True;
    if CreatePipe(hReadPipeInput, hWritePipeInput, @SecurityAttr, 0) and
      CreatePipe(hReadPipeOutput, hWritePipeOutput, @SecurityAttr, 0) and
      CreatePipe(hReadPipeError, hWritePipeError, @SecurityAttr, 0) then
    begin
      try
        ZeroMemory(@StartupInfo, SizeOf(StartupInfo)); // GetStartupInfo(StartupInfo);
        StartupInfo.cb := SizeOf(StartupInfo);
        StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; // Active wShowWindow et hStdOutput/hStdError
        StartupInfo.wShowWindow := SW_HIDE;
        StartupInfo.hStdInput := hReadPipeInput;
        StartupInfo.hStdOutput := hWritePipeOutput;
        StartupInfo.hStdError := hWritePipeError;
        ZeroMemory(@ProcessInfo, SizeOf(ProcessInfo));
        CmdLine := Format('"%s%s" %s', [IncludeTrailingPathDelimiter(CmdDirectory), CmdName, CmdParam]);
        Result := CreateProcess(nil, PChar(CmdLine), @SecurityAttr, @SecurityAttr, True, 0, nil, PChar(CmdDirectory), StartupInfo, ProcessInfo);
        if Result then
        begin
          try
            Terminated := False;
            AbortProcess := False;
            while not Terminated do
            begin
              case WaitForSingleObject(ProcessInfo.hProcess, Delay) of
                WAIT_OBJECT_0 :
                  begin
                    ReadPipes();
                    Terminated := True;
                  end;
                WAIT_ABANDONED : Terminated := True;
                WAIT_TIMEOUT :
                  begin
                    ReadPipes();
                    Terminated := Delay = INFINITE;
                  end;
                WAIT_FAILED: Abort;
              else
                Terminated := True;
              end;
 
              if (TimeOut > 0) and not AbortProcess and not Terminated then
              begin
                CurrentTick := GetTickCount();
                if CurrentTick >= ReadTick then
                  AbortProcess := (CurrentTick - ReadTick) > TimeOut
                else
                  ReadTick := CurrentTick; // Gère la limite de 49 jours du GetTickCount en accepant un Délai plus long
              end;
 
              if AbortProcess then
              begin
               HandleFunctionProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessInfo.dwProcessId);
               if HandleFunctionProcess > 0 then
               begin
                 TerminateProcess(HandleFunctionProcess, 0);
                 CloseHandle(HandleFunctionProcess);
               end;
              end;
            end;
 
            TULargeInteger(ExitCode).HighPart := 0;
            if not GetExitCodeProcess(ProcessInfo.hProcess, TULargeInteger(ExitCode).LowPart) then
              ExitCode := -1;
          finally
            CloseHandle(ProcessInfo.hThread);
            CloseHandle(ProcessInfo.hProcess); // The handles for both the process and the main thread must be closed through calls to CloseHandle
          end;
        end;
      finally
        CloseHandle(hReadPipeInput);
        CloseHandle(hWritePipeInput);
        CloseHandle(hReadPipeOutput);
        CloseHandle(hWritePipeOutput);
        CloseHandle(hReadPipeError);
        CloseHandle(hWritePipeError);
      end;
    end
    else
      raise Exception.Create('Impossible de créer les Pipes');
  except
    on E: Exception do
    begin
      OutputDebugString(PChar(Format('epcWindows.CallCmd Error %s, Message : %s', [E.ClassName, E.Message])));
      raise;
    end;
  end;
end;

**LaurentC33** · 09/10/2013, 09h28

Merci pour tout cela

En fait, le timeout c'est plutôt pour l'inverse, j'ai une commande qui prends énormément de temps entre deux retour, et je ne veux pas que le thread ce ferme. Donc dans ta méthode TimeOut = 0

Donc, j'utilise callCmd dans un thread, si je ferme le thread, j'ai bien le processus cmd.exe qui ce ferme automatiquement ?

**ShaiLeTroll** · 09/10/2013, 09h39

Ah, je n'avais donc rien compris

, j'ai eu des doutes

, j'ai tenté ma chance et voilà, j'aurais du me taire

Donc tu peux même reprendre l'ancienne forme de la fonction CallCmd qui diffère juste du TimeOut

Si tu sais que l'attente entre deux lectures est longue alors change Delay !
Attention, plus le Delay est long, plus le temps de réaction de AbortProcess sera long par conséquence

Et si tu change le booléen AbortProcess dans TThreadDosCommand.WaitEvent, cela arrêtera l'attente et forcera la fermeture du processus en cours !

je l'ai testé PHP.exe dans le thread principal
je l'ai fait en Thread aussi pour un EXE d'un prestataire a peu près comme je te l'ai écrit dans ma réponse précédente !
Je l'avoir aussi essayé avec CMD.EXE avec des fichiers BAT, je ne connais pas le /C !
Merci de l'astuce d'ailleurs

Je te conseille alors

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
procedure TThreadDosCommand.WaitEvent(const Output, Error: string; var AbortProcess: Boolean);
begin
 (* 
  Ici tu peux récupérer Output 
  Cela contient juste la dernière lecture
  Attention n'utilise pas de TMemo en TThread sans Synchronize !
*)
 
  AbortProcess := FAborted; // FAborted une propriété que tu ajoutes !
end;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
procedure TThreadDosCommand.AbortCommand()
begin
  FAborted := true;
  Terminate();
  WaitFor(); // Tu attends la fin du thread qui se bloque lors d'un 
end;

**LaurentC33** · 09/10/2013, 09h40

Très ingénieux le coup du var AbortProcess: Boolean

De rien, surtout merci à toi

**LaurentC33** · 09/10/2013, 09h55

Juste un petit problème.

Le compilateur me sort :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
E2033 Les types des paramètres VAR originaux et formels doivent être identiques

aux lignes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
CreatePipe(hReadPipeInput, hWritePipeInput, @SecurityAttr, 0)

Déclaration :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
function CreatePipe(var hReadPipe, hWritePipe: THandle;
  lpPipeAttributes: PSecurityAttributes; nSize: DWORD): BOOL; stdcall;

J'utilise XE5. Il faut que je parse les variables Cardinal en THandle ? Ca va suffire ?

**LaurentC33** · 09/10/2013, 09h57

J'ai changé la déclaration, le compilateur est heureux

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
hReadPipeInput, hWritePipeInput: THandle;
hReadPipeOutput, hWritePipeOutput: THandle;
hReadPipeError, hWritePipeError: THandle;

**LaurentC33** · 09/10/2013, 10h12

Encore un truc

Je n'arrive pas à trouver comment déclarer le pointeur de la méthode WaitEvent...

**ShaiLeTroll** · 09/10/2013, 13h23

Ah oui !
Faut peut-être mettre @

Version corrigée :
Il est important que _TThreadDosCommandWaitEvent soit déclaré en procédure et AVANT l'appel à CallCmd

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
procedure _TThreadDosCommandWaitEvent(Parent: Cardinal; const Output, Error: string; var AbortProcess: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).WaitEvent(Output, Error, AbortProcess);
  end;
end;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
procedure TThreadDosCommand.Execute();
var
  ExitCode: Int64;
  OutputText: string; 
  ErrorText: string;
begin
  CallCmd('', 'cmd.exe', '/C cd ........', ExitCode, OutputText, ErrorText, 200,  Self, @_TThreadDosCommandWaitEvent);
  (*
  Ici peu importe le traitement de WaitEvent
  OutputText contient TOUT le retour de la console
  ErrorText contient les messages d'erreur, c'est rarissime !
*)
end;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
procedure TThreadDosCommand.WaitEvent(const Output, Error: string; var AbortProcess: Boolean);
begin
 (* 
  Ici tu peux récupérer Output 
  Cela contient juste la dernière lecture
  Attention n'utilise pas de TMemo en TThread sans Synchronize !
*)
end;

**LaurentC33** · 09/10/2013, 14h30

Merci mais désolé, j'ai encore du mal à tout assimiler

1 - Tu me dis que "_TThreadDosCommandWaitEvent" doit être déclaré avant, tu veux dire que dans "implementation" elle doit être positionnée avant ?

2 - Je suis obligé d'utiliser CallCmd dans un thread ?

**LaurentC33** · 09/10/2013, 15h02

Je fait une classe pour piloter tes méthodes dans un thread :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
unit threadEpcWindows;
 
{
 
Classe de contrôle des méthodes de l'unité epcWindows
 
Ex :
 
procedure waitCallBack(const Output, Error: string; var AbortProcess: Boolean);
begin
   Form.Memo.Lines.Add(Output);
end;
 
procedure TForm.FormShow(Sender: TObject);
var
  dosThread: TThreadDosCommand;
begin
  dosThread := TThreadDosCommand.Create(True);
  dosThread.setCommand('', 'ipconfig', waitCallBack);
  dosThread.Start;
end;
 
);
 
 
 
}
 
interface
 
uses System.Classes, epcWindows;
 
type
  TWaitEvent = procedure(const Output, Error: string; var AbortProcess: Boolean);
 
  TThreadDosCommand = class(TThread)
    private
      prvtDirectory, prvtCommand: string;
      prvtWaitEvent: TWaitEvent;
      prvtAbortProcess: Boolean;
    public
      procedure setCommand(pDirectory, pCommand: string; pWaitEvent: TWaitEvent);
      procedure stopCommand;
    protected
      procedure Execute; override;
  end;
 
 
procedure _TThreadDosCommandWaitEvent(Parent: Cardinal; const Output, Error: string; var AbortProcess: Boolean); stdcall;
 
implementation
 
procedure _TThreadDosCommandWaitEvent(Parent: Cardinal; const Output, Error: string; var AbortProcess: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).prvtWaitEvent(Output, Error, AbortProcess);
  end;
end;
 
{ TThreadCommand }
 
procedure TThreadDosCommand.Execute;
var
  ExitCode: Int64;
  OutputText: string;
  ErrorText: string;
begin
  inherited;
  prvtAbortProcess := false;
  CallCmd(prvtDirectory, 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 100,  Self.Handle, _TThreadDosCommandWaitEvent);
end;
 
procedure TThreadDosCommand.setCommand(pDirectory, pCommand: string; pWaitEvent: TWaitEvent);
begin
  prvtDirectory := pDirectory;
  prvtCommand := pCommand;
  prvtWaitEvent := pWaitEvent;
end;
 
 
 
procedure TThreadDosCommand.stopCommand;
begin
  prvtAbortProcess := true;
end;
 
end.

**LaurentC33** · 09/10/2013, 15h27

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
CallCmd(prvtDirectory, 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 100,  Self, _TThreadDosCommandWaitEvent);

Self ne passe pas sous XE5

Commande DOS affichée dans memo, le tout dans un thread

Delphi

Discussions similaires

Partager

Partager