Convert a delphi function to Lazarus function

[mmgserver]

Hello,
I'm trying to port a project I'm currently working from Delphi to Lazarus.

A key function in the delphi project is the a functions that return into the GUI the response from a console application.

Code: Pascal  [Select][+][-]

1. function GetDosOutput(CommandLine: string): string;
2. var
3.   SA: TSecurityAttributes;
4.   SI: TStartupInfo;
5.   PI: TProcessInformation;
6.   StdOutPipeRead, StdOutPipeWrite: THandle;
7.   WasOK: Boolean;
8.   Buffer: array[0..255] of AnsiChar;
9.   BytesRead: Cardinal;
10.   Handle: Boolean;
11. begin
12.   Result := '';
13.   with SA do begin
14.     nLength := SizeOf(SA);
15.     bInheritHandle := True;
16.     lpSecurityDescriptor := nil;
17.   end;
18.   CreatePipe(StdOutPipeRead, StdOutPipeWrite, @SA, 0);
19.   try
20.     with SI do
21.     begin
22.       FillChar(SI, SizeOf(SI), 0);
23.       cb := SizeOf(SI);
24.       dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
25.       wShowWindow := SW_HIDE;
26.       hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect stdin
27.       hStdOutput := StdOutPipeWrite;
28.       hStdError := StdOutPipeWrite;
29.     end;
30.     Handle := CreateProcess(nil, PChar('cmd.exe /C ' + CommandLine),
31.                             nil, nil, True, 0, nil,
32.                             nil, SI, PI);
33.     CloseHandle(StdOutPipeWrite);
34.     if Handle then
35.       try
36.         repeat
37.           WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
38.           if BytesRead > 0 then
39.           begin
40.             Buffer[BytesRead] := #0;
41.             Result := Result + Buffer;
42.           end;
43.         until not WasOK or (BytesRead = 0);
44.         WaitForSingleObject(PI.hProcess, INFINITE);
45.       finally
46.         CloseHandle(PI.hThread);
47.         CloseHandle(PI.hProcess);
48.       end;
49.   finally
50.     CloseHandle(StdOutPipeRead);
51.   end;
52. end;

The Lazarus counterpart that works best in my case appears to be this:

Code: Pascal  [Select][+][-]

1. function get_shell_output(const comanda_de_executat:string):string;
2. const
3. READ_BYTES = 2048;
4.  
5. var
6. OutputLines: TStringList;
7. MemStream: TMemoryStream;
8. Process: TProcess;
9. NumBytes: LongInt;
10. BytesRead: LongInt;
11.  
12. begin
13. result:='';
14. // A temp Memorystream is used to buffer the output
15. MemStream := TMemoryStream.Create;
16. BytesRead := 0;
17.  
18. Process := TProcess.Create(nil);
19. //Process.Options := [poUsePipes,poStderrToOutPut];
20. Process.Options := [poUsePipes];
21. Process.ShowWindow := swoHIDE;
22.  
23. {$IFDEF Windows}
24. Process.Executable := 'c:\windows\system32\cmd.exe';
25. Process.Parameters.Add('/c');
26. Process.Parameters.Add(comanda_de_executat);
27. {$ENDIF Windows}
28. {$IFDEF Unix}
29. Process.Executable := '/bin/ls';
30. Process.Parameters.Add('-c');
31. Process.Parameters.Add(comanda_de_executat);
32. {$ENDIF Unix}
33.  
34. // We cannot use poWaitOnExit here since we don’t
35. // know the size of the output. On Linux the size of the
36. // output pipe is 2 kB; if the output data is more, we
37. // need to read the data. This isn’t possible since we are
38. // waiting. So we get a deadlock here if we use poWaitOnExit.
39.  
40. Process.Execute;
41. while Process.Running do
42. begin
43. // make sure we have room
44. MemStream.SetSize(BytesRead + READ_BYTES);
45.  
46. // try reading it
47. NumBytes := Process.Output.Read((MemStream.Memory + BytesRead)^, READ_BYTES);
48. if NumBytes > 0
49. then begin
50. Inc(BytesRead, NumBytes);
51. end
52. else begin
53. // no data, wait 100 ms
54. Sleep(100);
55. end;
56. end;
57. // read last part
58. repeat
59. // make sure we have room
60. MemStream.SetSize(BytesRead + READ_BYTES);
61. // try reading it
62. NumBytes := Process.Output.Read((MemStream.Memory + BytesRead)^, READ_BYTES);
63. if NumBytes > 0
64. then begin
65. Inc(BytesRead, NumBytes);
66. end;
67. until NumBytes=0;
68. MemStream.SetSize(BytesRead);
69.  
70. OutputLines := TStringList.Create;
71. OutputLines.LoadFromStream(MemStream);
72.  
73. for NumBytes := 0 to OutputLines.Count-1 do
74. begin
75. result:=result+slinebreak+OutputLines[NumBytes];
76. end;
77. OutputLines.Free;
78. Process.Free;
79. MemStream.Free;
80. end;

The problem is that function "getdosoutput" is able to capture and return to gui some complex console output while "function get_shell_output" works ok only with commands adressed to cmd.

ex:
"getdosoutput" return output from this command: psexec \\server1 -u myusername -p mypassword -s -h cmd /c (hostname)^&(ipconfig /all)
"get_shell_output" return no output from the command: psexec \\server1 -u myusername -p mypassword -s -h cmd /c (hostname)^&(ipconfig /all)

Could someone please enlight me?

[marcov]

The first seems to do what poStderrToOutPut (which is commented out) would do in the second, redirect stderr to stdout.

But it all looks horribly complex, how about something like:

Code: Pascal  [Select][+][-]

1. function GetDosOutput(CommandLine: string): string;
2. begin
3.   runcommand('cmd.exe',['/C',commandline],result,[poStderrToOutPut]);
4. end;

[mmgserver]

The first seems to do what poStderrToOutPut (which is commented out) would do in the second, redirect stderr to stdout.

But it all looks horribly complex, how about something like:

Code: Pascal  [Select][+][-]

1. function GetDosOutput(CommandLine: string): string;
2. begin
3.   runcommand('cmd.exe',['/C',commandline],result,[poStderrToOutPut]);
4. end;

The output to GUI is exactly as the function I posted. I don't receive the ip data:

Code: Pascal  [Select][+][-]

1. PsExec v2.1 - Execute processes remotely
2. Copyright (C) 2001-2013 Mark Russinovich
3. Sysinternals - www.sysinternals.com
4.  
5.  
6. Windows IP Configuration
7.  
8. Connecting to server...
9.  
10. Starting PSEXESVC service on server...
11.  
12. Connecting with PsExec service on server...
13.  
14. Starting ipconfig on server...
15.  
16. ipconfig exited on server with error code 0

.


And this the output from the same command runned with delphi function:

Code: Pascal  [Select][+][-]

1. SERVER
2.  
3.  
4.  
5. Windows IP Configuration
6.  
7.  
8.  
9.    Host Name . . . . . . . . . . . . : server
10.  
11.    Primary Dns Suffix  . . . . . . . : 0.0.0.0
12.  
13.    Node Type . . . . . . . . . . . . : Hybrid
14.  
15.    IP Routing Enabled. . . . . . . . : Yes
16.  
17.    WINS Proxy Enabled. . . . . . . . : No
18.  
19.    DNS Suffix Search List. . . . . . : test
20.  
21.                                        
22.  
23.  
24.  
25.  
26.  
27. Ethernet adapter x:
28.  
29.  
30.  
31.    Connection-specific DNS Suffix  . : test
32.  
33.    Description . . . . . . . . . . . : Adapter
34.  
35.    Physical Address. . . . . . . . . : 00-00-00-00-00-00
36.  
37.    DHCP Enabled. . . . . . . . . . . : No
38.  
39.    Autoconfiguration Enabled . . . . : Yes
40.  
41.    IPv4 Address. . . . . . . . . . . : xxx.xxx.xxx.xxx(Preferred)
42.  
43.    Subnet Mask . . . . . . . . . . . : xxx.xxx.xxx.xxx
44.  
45.    Default Gateway . . . . . . . . . : xxx.xxx.xxx.xxx
46.  
47.    DNS Servers . . . . . . . . . . . : xxx.xxx.xxx.xxx
48.  
49.                                        xxx.xxx.xxx.xxx
50.  
51.    NetBIOS over Tcpip. . . . . . . . : Enabled
52.  
53.  
54.  
55. Tunnel adapter x2:
56.  
57.  
58.  
59.    Connection-specific DNS Suffix  . :
60.  
61.    Description . . . . . . . . . . . : Adapter 2
62.  
63.    Physical Address. . . . . . . . . : 00-00-00-00-00-00
64.  
65.    DHCP Enabled. . . . . . . . . . . : No
66.  
67.    Autoconfiguration Enabled . . . . : Yes
68.  
69.    IPv4 Address. . . . . . . . . . . : xxx.xxx.xxx.xxx(Preferred)
70.  
71.    Subnet Mask . . . . . . . . . . . : xxx.xxx.xxx.xxx
72.  
73.    Default Gateway . . . . . . . . . :
74.  
75.    NetBIOS over Tcpip. . . . . . . . : Enabled

After more investigation there seems to be a bug mening the console never closes after finishing the task.If I manualy close the console windows I receive the expected data.
I found that someone reported this problem on stackoverflow: https://stackoverflow.com/questions/14158870/console-application-never-returns-when-ran-with-tprocess

Is there any solution to it? Can the console be closed after running the command?

[marcov]

My guess it is the way it makes inheritable pipes.

That change is quite old, mantis https://bugs.freepascal.org/view.php?id=19325

The offending code is in process.inc:createpipehandles.

That report is a fix for not closing consoles, but has apparently as sideeffect that it is incompatible with the setup you are running.

If I have more time I'll test if it is with all pipe output "program x which starts program y" scenarios. It might be that psexecv does something not terribly standard.

[mmgserver]

My guess it is the way it makes inheritable pipes.

That change is quite old, mantis https://bugs.freepascal.org/view.php?id=19325

The offending code is in process.inc:createpipehandles.

That report is a fix for not closing consoles, but has apparently as sideeffect that it is incompatible with the setup you are running.

If I have more time I'll test if it is with all pipe output "program x which starts program y" scenarios. It might be that psexecv does something not terribly standard.

Thank you for your time and help!
I've check the "proces.inc" and indeed has the duplicatehandle function, so as you mentioned this is a prbably a side effect of that workaround.

[marcov]

Follow up.

For similar problems, new options have been added,probably just before FPC 3.2.0

This provides a workaround has been added for this, This problem has been fixed. In cases like this pass "popassinput" in the options.   

Example:

Code: Pascal  [Select][+][-]

1. unit mainprocesstomemo;
2. // piping problem.
3. // https://forum.lazarus.freepascal.org/index.php/topic,42385.0/topicseen.html
4. {$mode delphi}{$H+}
5.  
6. interface
7.  
8. uses
9.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Process, Pipes;
10.  
11. Type
12.   { TForm1 }
13.  
14.   TForm1 = class(TForm)
15.     buipconfig: TButton;
16.     buremoteipconfig: TButton;
17.     Memo1: TMemo;
18.     procedure buipconfigClick(Sender: TObject);
19.     procedure buremoteipconfigClick(Sender: TObject);
20.   private
21.   public
22.     procedure ProcessEvent(Sender,Context : TObject;Status:TRunCommandEventCode;const Message:string);
23.   end;
24.  
25. var
26.   Form1: TForm1;
27.  
28. implementation
29.  
30. {$R *.lfm}
31.  
32. { TProcessMemo }
33. Type
34.  
35.  TProcessToMemo = class(TProcess)
36.                             public
37.                             fmemo : Tmemo;
38.                             bytesprocessed : integer;
39.                             fstringsadded : integer;
40.                             function ReadInputStream(p:TInputPipeStream;var BytesRead:integer;var DataLength:integer;var Data:string;MaxLoops:integer=10):boolean;override;
41.                           end;
42.  
43.  
44.  
45. function RunCommandMemo(const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone;memo:TMemo=nil;runrefresh : TOnRunCommandEvent=nil ):boolean;
46. Var
47.     p : TProcessToMemo;
48.     i,
49.     exitstatus : integer;
50.     ErrorString : String;
51. begin
52.   p:=TProcessToMemo.create(nil);
53.   if Options<>[] then
54.     P.Options:=Options - [poRunSuspended,poWaitOnExit];
55.   p.options:=p.options+[poRunIdle];
56.  
57.   P.ShowWindow:=SwOptions;
58.   p.Executable:=exename;
59.   if high(commands)>=0 then
60.    for i:=low(commands) to high(commands) do
61.      p.Parameters.add(commands[i]);
62.   p.fmemo:=memo;
63.   p.OnRunCommandEvent:=runrefresh;
64.   try
65.     result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0;
66.   finally
67.     p.free;
68.   end;
69.   if exitstatus<>0 then result:=false;
70. end;
71.  
72. { TForm1 }
73.  
74. procedure TForm1.buipconfigClick(Sender: TObject);
75. var s : string;
76. begin
77.  // simple case.
78.   RunCommandMemo('cmd.exe',['/w','/c','ipconfig'],s,[],swonone,memo1,ProcessEvent);
79. end;
80.  
81. procedure TForm1.buremoteipconfigClick(Sender: TObject);
82. var s,cmd : string;
83. begin
84.   cmd := 'psexec \\xxxx -u someuser-p somepass -s -h cmd /c (hostname)^&(ipconfig /all)';
85.   RunCommandMemo('cmd.exe',['/w','/c',cmd],s,[poPassInput,poStderrToOutPut],swonone,memo1,ProcessEvent);
86.   memo1.lines.add(s);
87. end;
88.  
89. procedure TForm1.ProcessEvent(Sender, Context: TObject;
90.   Status: TRunCommandEventCode; const Message: string);
91. begin
92.   if status in [RunCommandIdle, RunCommandFinished] then
93.     begin
94.       if status =RunCommandFinished then
95.         begin
96.           memo1.lines.add(' process finished');
97.         end;
98.       if tprocesstomemo(sender).fstringsadded>0 then
99.        begin
100.          tprocesstomemo(sender).fstringsadded:=0;
101. //         memo1.lines.add('Handle:'+inttostr(tprocesstomemo(sender).ProcessHandle));
102.          memo1.refresh;
103.        end;
104.       sleep(10);
105.       application.ProcessMessages;
106.     end;
107. end;
108.  
109. { TProcessToMemo }
110.  
111.  
112. function TProcessToMemo.ReadInputStream(p:TInputPipeStream;var BytesRead:integer;var DataLength:integer;var Data:string;MaxLoops:integer=10):boolean;
113. var lfpos : integer;
114.     crcorrectedpos:integer;
115.     stradded : integer;
116.     newstr : string;
117. begin
118.   Result:=inherited ReadInputStream(p, BytesRead, DataLength, data, MaxLoops);
119.   if (result) and (bytesread>bytesprocessed)then
120.     begin
121.       stradded:=0;
122.       lfpos:=pos(#10,data,bytesprocessed+1);
123.       while (lfpos<>0) and (lfpos<=bytesread) do
124.         begin
125.           crcorrectedpos:=lfpos;
126.           if (crcorrectedpos>0) and (data[crcorrectedpos-1]=#13) then
127.              dec(crcorrectedpos);
128.           newstr:=copy(data,bytesprocessed+1,crcorrectedpos-bytesprocessed-1);
129.           fmemo.lines.add(newstr);
130.            inc(stradded);
131.           bytesprocessed:=lfpos;
132.           lfpos:=pos(#10,data,bytesprocessed+1);
133.         end;
134.       inc(fstringsadded,stradded); // check idle event.
135.     end;
136. end;
137.  
138. end.
139.