Recent

Author Topic: Convert a delphi function to Lazarus function  (Read 2747 times)

mmgserver

  • New member
  • *
  • Posts: 6
Convert a delphi function to Lazarus function
« on: August 29, 2018, 01:34:38 pm »
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

  • Administrator
  • Hero Member
  • *
  • Posts: 10071
  • FPC developer.
Re: Convert a delphi function to Lazarus function
« Reply #1 on: August 29, 2018, 01:41:31 pm »
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;
« Last Edit: August 29, 2018, 01:44:40 pm by marcov »

mmgserver

  • New member
  • *
  • Posts: 6
Re: Convert a delphi function to Lazarus function
« Reply #2 on: August 29, 2018, 01:54:50 pm »
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?
« Last Edit: August 29, 2018, 02:26:33 pm by mmgserver »

marcov

  • Administrator
  • Hero Member
  • *
  • Posts: 10071
  • FPC developer.
Re: Convert a delphi function to Lazarus function
« Reply #3 on: August 29, 2018, 02:36:33 pm »
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.
« Last Edit: August 29, 2018, 02:52:48 pm by marcov »

mmgserver

  • New member
  • *
  • Posts: 6
Re: Convert a delphi function to Lazarus function
« Reply #4 on: August 30, 2018, 10:45:13 am »
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

  • Administrator
  • Hero Member
  • *
  • Posts: 10071
  • FPC developer.
Re: Convert a delphi function to Lazarus function
« Reply #5 on: May 26, 2022, 03:16:17 pm »
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.  

 

TinyPortal © 2005-2018