Ir al contenido



Foto

Ayuda con automatización de Procesos

Automatización Procesos Consola

  • Por favor identifícate para responder
26 respuestas en este tema

#1 Edson

Edson

    Member

  • Miembros
  • PipPip
  • 26 mensajes

Escrito 07 diciembre 2016 - 09:44

Holas. Deseo abrir un proceso de consola (como el CMD o el FTP), de forma interactiva, de modo que pueda enviar comandos y leer la respuesta. Ya he probado abriendo un proceso e interactuando con el stdin y el stdout, pero esto no funciona para programas como el FTP de Windows,  que al parecer detectan cuando están "conectados" a una consola.
En particular he probado el código de: http://stackoverflow...-through-delphi
pero como digo, no funciona solo manejar stdin/stdout/stderr.

Mi solución final es para implementarlo en Lazarus, pero recurro a ustedes, con la epseranza de poder portar el código fácilmente.

Gracias de antemano.


  • 0

#2 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 07 diciembre 2016 - 10:11

Prueba esto y lee esto: Capturar la salida de consola: DosCommand

:
 


delphi
  1. function CmdConsoleCommand(CommandLine: String): String;
  2. var
  3. Buffer: array [0..4096] of char;
  4. pipeRead, pipeWrite: THandle;
  5. sa: SECURITY_ATTRIBUTES;
  6. si: STARTUPINFO;
  7. pi: PROCESS_INFORMATION;
  8. dwRead: DWORD;
  9. begin
  10. Result:= '';
  11. if CommandLine[2] = ':' then
  12. SetCurrentDirectory(PCHAR(CommandLine));
  13.  
  14. // Ejecuto comando y devuelvo resultado
  15. GetEnvironmentVariable('COMSPEC', @Buffer[0], sizeof(Buffer));
  16. lstrcat(Buffer, ' /C ');
  17. lstrcat(Buffer, PCHAR(CommandLine));
  18. ZeroMemory(@sa, sizeof(SECURITY_ATTRIBUTES));
  19. sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  20. sa.bInheritHandle:= TRUE;
  21.  
  22. if CreatePipe(pipeRead, pipeWrite, @sa, 25*1024) then
  23. begin
  24. ZeroMemory(@si, sizeof(STARTUPINFO));
  25. si.cb:= sizeof(STARTUPINFO);
  26. ZeroMemory(@pi, sizeof(PROCESS_INFORMATION));
  27. si.hStdOutput:= pipeWrite;
  28. si.hStdError := pipeWrite;
  29. si.hStdInput := pipeWrite;
  30. si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  31. si.wShowWindow:= SW_HIDE;
  32.  
  33. if CreateProcess(0, @Buffer[0], 0, 0, TRUE, 0, 0, 0, si, pi) then
  34. begin
  35. CloseHandle(pi.hThread);
  36. if WaitForSingleObject(pi.hProcess, 9000) = WAIT_OBJECT_0 then
  37. begin
  38. dwRead:= 0;
  39. Buffer[0]:= ' '; // un espacio
  40. WriteFile(pipeWrite, Buffer[0], 1, dwRead, 0);
  41. repeat
  42. ZeroMemory(@Buffer[0], sizeof(Buffer));
  43. ReadFile(pipeRead, Buffer, sizeof(Buffer), dwRead, 0);
  44. OemToCharBuffA(Buffer, Buffer, dwRead);
  45. Result:= Result + String(Buffer);
  46. until dwRead <= sizeof(Buffer);
  47. end; //WaitForSingleObject
  48. CloseHandle(pi.hProcess);
  49. end; //CreateProcess
  50. CloseHandle(pipeRead);
  51. CloseHandle(pipeWrite);
  52. end; //CreatePipe
  53. end;

Pero si lo que deseas es usar ftp, no va a funcionar.

Saludos.


  • 0

#3 Edson

Edson

    Member

  • Miembros
  • PipPip
  • 26 mensajes

Escrito 07 diciembre 2016 - 11:37

Gracias escafandra. Precisamente, lo que deseo, es interactuar con el FTP, desde mi aplicación.


  • 0

#4 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 07 diciembre 2016 - 01:22

Quizás puedas usar la API para FTP Sessions y te olvidas de la consola.

 

 

Saludos.


  • 0

#5 Edson

Edson

    Member

  • Miembros
  • PipPip
  • 26 mensajes

Escrito 07 diciembre 2016 - 02:24

Gracias por el enlace, escafandra. Pero mi requerimiento es que necesito ejecutar de forma interactiva el FTP, que viene por defecto en Windows (en general cualquier aplicación de consola).

 

Mi problema no se remite solo al FTP, sino a cualquier aplicación de consola, de modo que se puedan capturar los mismos mensajes que esta aplicación enviaría a una consola como el CMD de Windows.


  • 0

#6 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 08 diciembre 2016 - 01:43

El problema de ese tipo de aplicaciones ligadas a la consola es que precisan de una consola real. Es por eso que el código que te mostré no funciona para ellos y otros muchos que encuentres, tampoco.
 
Vamos a hacer una aproximación:
1- Necesitas una consola real abierta y oculta.
2- Necesitas Pipes de lectura y escritura.
3- Necesitas leer y escribir en tiempo real sin cerrar la consola.
4- Necesitas poder cerrar la consola al terminar.
 
He escrito una clase que hace todo eso y te permite actuar de forma interactiva con una consola que abre uno de esos programas estilo FTP.


delphi
  1. unit PipeShell2;
  2.  
  3.  
  4. interface
  5.  
  6. uses
  7. Windows, Messages, SysUtils, Classes;
  8.  
  9. const
  10. BUFFERSIZE = 4*1024;
  11.  
  12. type
  13. TPipeShell = class
  14. private
  15. PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
  16. hProcess: THANDLE;
  17. Buffer: PAnsiChar;
  18. protected
  19. public
  20. constructor Create;
  21. destructor Destroy; override;
  22. function Write(S: String): DWORD;
  23. function Read: String;
  24. end;
  25.  
  26. implementation
  27.  
  28. constructor TPipeShell.Create;
  29. var
  30. sa: SECURITY_ATTRIBUTES;
  31. si: STARTUPINFO;
  32. pi: PROCESS_INFORMATION;
  33. begin
  34. PipeIn:= 0;
  35. PipeOut:= 0;
  36. PipeWrite:= 0;
  37. PipeRead:= 0;
  38. hProcess:= 0;
  39.  
  40. GetMem(Buffer, BUFFERSIZE);
  41.  
  42. sa.lpSecurityDescriptor:= nil;
  43. sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  44. sa.bInheritHandle := TRUE;
  45. // Tuberia de entrada
  46. if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  47. begin
  48. // Tuberia de salida
  49. if CreatePipe(PipeRead, PipeOut, @sa, 0) then
  50. begin
  51. GetStartupInfo(Si);
  52. // Indicamos tuberias del proceso
  53. si.hStdOutput:= PipeOut;
  54. si.hStdError:= PipeOut;
  55. si.hStdInput:= PipeIn;
  56. si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  57. si.wShowWindow:= SW_HIDE;
  58. //si.wShowWindow:= SW_SHOW;
  59. // Ruta del shell
  60. ZeroMemory(Buffer, BUFFERSIZE);
  61. GetEnvironmentVariable('COMSPEC', Buffer, BUFFERSIZE - 1);
  62. // Ejecutamos el shell
  63. if CreateProcess(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi) then
  64. begin
  65. hProcess:= pi.hProcess;
  66. CloseHandle(pi.hThread);
  67. end;
  68. end;
  69. end;
  70. end;
  71.  
  72. destructor TPipeShell.Destroy;
  73. var
  74. ExitCode: DWORD;
  75. begin
  76. // Tratamos de terminar el shell
  77. Write('quit');
  78. Write('exit');
  79. if PipeIn <> 0 then CloseHandle(PipeIn);
  80. if PipeOut <> 0 then CloseHandle(PipeOut);
  81. if PipeWrite <> 0 then CloseHandle(PipeWrite);
  82. if PipeRead <> 0 then CloseHandle(PipeRead);
  83. if hProcess <> 0 then CloseHandle(hProcess);
  84. if Buffer <> nil then FreeMem(Buffer);
  85. if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
  86. TerminateProcess(hProcess, DWORD(-1));
  87. //GetExitCodeProcess(hProcess, ExitCode);
  88. //inherited;
  89. end;
  90.  
  91. function TPipeShell.Write(S: String): DWORD;
  92. begin
  93. lstrcpy(Buffer, PCHAR(S + #10));
  94. WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
  95. end;
  96.  
  97. function TPipeShell.Read: String;
  98. var
  99. dwRead, dwBytesAvail: DWORD;
  100. begin
  101. dwRead:= 0;
  102. // Esperamos a que tengamos algo que leer en PipeRead
  103. repeat
  104. sleep(100);
  105. PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
  106. until dwRead > 0;
  107. // Leemos y vaciamos el PipeRead
  108. ZeroMemory(Buffer, BUFFERSIZE);
  109. ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
  110. OemToCharBuffA(Buffer, Buffer, dwRead);
  111. Result:= String(Buffer);
  112. end;
  113.  
  114. end.

Para usarla, lo harás como con cualquier clase, la creas y la destruyes. Write y Read te permiten escribir comandos y leer el resultado.
 
Probablemente esta clase se tenga que pulir un poco más pero tal como está es funcionante.
 
Un ejemplo de uso en un proyecto VCL:


delphi
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7. Dialogs, StdCtrls, PipeShell2;
  8.  
  9. type
  10. TForm3 = class(TForm)
  11. Button1: TButton;
  12. Edit1: TEdit;
  13. Memo1: TMemo;
  14. procedure FormCreate(Sender: TObject);
  15. procedure FormClose(Sender: TObject; var Action: TCloseAction);
  16. procedure Button1Click(Sender: TObject);
  17. private
  18. PipeShell: TPipeShell;
  19. public
  20. { Public declarations }
  21. end;
  22.  
  23. var
  24. Form3: TForm3;
  25.  
  26. implementation
  27.  
  28. {$R *.dfm}
  29.  
  30. procedure TForm3.FormCreate(Sender: TObject);
  31. begin
  32. PipeShell:= TPipeShell.Create;
  33. Memo1.Text:= PipeShell.Read;
  34. end;
  35.  
  36. procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
  37. begin
  38. PipeShell.Free;
  39. end;
  40.  
  41. procedure TForm3.Button1Click(Sender: TObject);
  42. begin
  43. PipeShell.Write(Edit1.Text);
  44. Memo1.Text:= StringReplace(PipeShell.Read, #10, #13+#10, [rfReplaceAll]);
  45. end;
  46.  
  47. end.

post-12294-0-76876200-1481226684.jpg

 

Subo el código fuente y proyecto de ejemplo.
 
 
 
Saludos.

Archivos adjuntos


  • 0

#7 Edson

Edson

    Member

  • Miembros
  • PipPip
  • 26 mensajes

Escrito 08 diciembre 2016 - 07:41

Excelente. Voy a revisarlo a ver si lo puedo adaptar a Lazarus.

 

Gracias.


  • 0

#8 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 09 diciembre 2016 - 01:31

Esta versión es compatible con Lazarus y delphi. He incluido alguna mejora al destruir la consola.


delphi
  1. unit PipeShell2;
  2.  
  3.  
  4. interface
  5.  
  6. uses
  7. Windows, Messages, SysUtils, Classes;
  8.  
  9. const
  10. BUFFERSIZE = 4*1024;
  11.  
  12. type
  13. TPipeShell = class
  14. private
  15. PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
  16. hProcess: THANDLE;
  17. Buffer: PAnsiChar;
  18. protected
  19. public
  20. constructor Create;
  21. destructor Destroy; override;
  22. function Write(S: String): DWORD;
  23. function Read: String;
  24. end;
  25.  
  26. implementation
  27.  
  28. constructor TPipeShell.Create;
  29. var
  30. sd: SECURITY_DESCRIPTOR;
  31. sa: SECURITY_ATTRIBUTES;
  32. si: STARTUPINFO;
  33. pi: PROCESS_INFORMATION;
  34. begin
  35. PipeIn:= 0;
  36. PipeOut:= 0;
  37. PipeWrite:= 0;
  38. PipeRead:= 0;
  39. hProcess:= 0;
  40.  
  41. GetMem(Buffer, BUFFERSIZE);
  42. InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  43. sa.lpSecurityDescriptor:= @sd;
  44. // sa.lpSecurityDescriptor:= nil;
  45. sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  46. sa.bInheritHandle:= TRUE;
  47. // Tuberia de entrada
  48. if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  49. begin
  50. // Tuberia de salida
  51. if CreatePipe(PipeRead, PipeOut, @sa, 0) then
  52. begin
  53. GetStartupInfo(Si);
  54. // Indicamos tuberias del proceso
  55. si.hStdOutput:= PipeOut;
  56. si.hStdError:= PipeOut;
  57. si.hStdInput:= PipeIn;
  58. si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  59. si.wShowWindow:= SW_HIDE;
  60. //si.wShowWindow:= SW_SHOW;
  61. // Ruta del shell
  62. ZeroMemory(Buffer, BUFFERSIZE);
  63. GetEnvironmentVariableA('COMSPEC', Buffer, BUFFERSIZE - 1);
  64. // Ejecutamos el shell
  65. if CreateProcess(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi) then
  66. begin
  67. hProcess:= pi.hProcess;
  68. CloseHandle(pi.hThread);
  69. end;
  70. end;
  71. end;
  72. end;
  73.  
  74. destructor TPipeShell.Destroy;
  75. var
  76. ExitCode: DWORD;
  77. begin
  78. // Tratamos de terminar el shell
  79. repeat
  80. Write('quit'); Read;
  81. Write('q'); Read;
  82. Write('exit'); Read;
  83. GetExitCodeProcess(hProcess, ExitCode);
  84. until ExitCode <> STILL_ACTIVE;
  85.  
  86. if PipeIn <> 0 then CloseHandle(PipeIn);
  87. if PipeOut <> 0 then CloseHandle(PipeOut);
  88. if PipeWrite <> 0 then CloseHandle(PipeWrite);
  89. if PipeRead <> 0 then CloseHandle(PipeRead);
  90. if hProcess <> 0 then CloseHandle(hProcess);
  91. if Buffer <> nil then FreeMem(Buffer);
  92. if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
  93. TerminateProcess(hProcess, DWORD(-1));
  94. //GetExitCodeProcess(hProcess, ExitCode);
  95. //inherited;
  96. end;
  97.  
  98. function TPipeShell.Write(S: String): DWORD;
  99. begin
  100. if PipeWrite = 0 then exit;
  101. lstrcpy(Buffer, PCHAR(S + #10));
  102. WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
  103. end;
  104.  
  105. function TPipeShell.Read: String;
  106. var
  107. dwRead, dwBytesAvail: DWORD;
  108. begin
  109. if PipeRead = 0 then exit;
  110.  
  111. dwRead:= 0;
  112. // Esperamos a que tengamos algo que leer en PipeRead
  113. repeat
  114. sleep(100);
  115. PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
  116. if dwRead > 0 then
  117. begin
  118. // Leemos y vaciamos el PipeRead
  119. ZeroMemory(Buffer, BUFFERSIZE);
  120. ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
  121. OemToCharBuffA(Buffer, Buffer, dwRead);
  122. Result:= Result + String(Buffer);
  123. end;
  124. until dwBytesAvail = 0;
  125. end;
  126.  
  127. end.

Subo proyecto delphi y Lazarus.

 

 

Saludos.

Archivos adjuntos


  • 1

#9 Edson

Edson

    Member

  • Miembros
  • PipPip
  • 26 mensajes

Escrito 11 diciembre 2016 - 07:51

La versión para Lazarus, no funciona. Al compilar con Lazarus 1.6.2, genera el error:

 

"PipeShell2.pas(53,24) Error: Call by var for arg no. 1 has to match exactly: Got "STARTUPINFO" expected "STARTUPINFOA""

 

En la línea 53:


php
  1.       GetStartupInfo(Si);

Parece que no acepta el parámetro "Si" de tipo STARTUPINFO. Si lo cambio a STARTUPINFOA, compila, pero al eejcutarse genera una excepción SIGSEV.


  • 0

#10 Delphius

Delphius

    Advanced Member

  • Administrador
  • 6.258 mensajes
  • LocationArgentina

Escrito 11 diciembre 2016 - 10:10

La versión para Lazarus, no funciona. Al compilar con Lazarus 1.6.2, genera el error:

 

"PipeShell2.pas(53,24) Error: Call by var for arg no. 1 has to match exactly: Got "STARTUPINFO" expected "STARTUPINFOA""

 

En la línea 53:


php
  1.       GetStartupInfo(Si);

Parece que no acepta el parámetro "Si" de tipo STARTUPINFO. Si lo cambio a STARTUPINFOA, compila, pero al eejcutarse genera una excepción SIGSEV.

 

Umm. Es raro, si pidiera cambiar el tipo lo normal sería que también se cambie la función por el tipo.

No he visto en detalle el caso pero podrías probar con cambiar GetStartupInfo por GetStartupInfoA, que es la que se espera cuando se trabaja con la versión ANSI.

 

Saludos,


  • 0

#11 Edson

Edson

    Member

  • Miembros
  • PipPip
  • 26 mensajes

Escrito 11 diciembre 2016 - 10:32

GetStartupInfoA() también espera un LPSTARTUPINFOA y no me deja compilar. ¿Tal vez tenga que ver que estoy compilando en 64 bits? No creo, pero de todas formas el código no compila en Lazarus.


  • 0

#12 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 12 diciembre 2016 - 12:43

GetStartupInfoA() también espera un LPSTARTUPINFOA y no me deja compilar. ¿Tal vez tenga que ver que estoy compilando en 64 bits? No creo, pero de todas formas el código no compila en Lazarus.


El proyecto Lazarus subido compila y se ejecuta sin errores en Lazarus v1.6.2 32bits.
 
Las versones A de la API se refieren a AnsiChar. Las W a WCHAR. Según el compilador elige una u otra cuando no se especifica. Esto ocurre con todos los compiladores incluido Lazarus. Si miras el código, te darás cuenta que está enfocado hacia AnsiChar.
 
Cuando tenga a mano Lazarus 64 bits lo pruebo. Como dice Delphius, es cuestión de tipos.

No subo código sin probar y mucho menos un proyecto completo.


Saludos.


  • 0

#13 Delphius

Delphius

    Advanced Member

  • Administrador
  • 6.258 mensajes
  • LocationArgentina

Escrito 12 diciembre 2016 - 05:02

Yo tengo CodeTyphon 5.6 en 64 y 32bits.

Puedo hacer la prueba de compilarlo recién por la tarde, dentro de unas 8 o 10 horas. En estos momentos me estoy yendo por unos trabajos.

 

Saludos,


  • 0

#14 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 12 diciembre 2016 - 10:17

No tengo Lazarus 64 v1.6.2 (para instalarlo tengo que eliminar la versión 32bits) pero he hecho cross compiler 32->64 con el código publicado y sigue compilando y ejecutando correctamente la versión 64 del ejemplo.

 

Es posible que la versión Lazarus 64 esté más enfocada a UNICODE y por eso aparezcan errores que no puedo reproducir. En ese caso conviene usar las versiones A de la API, puesto que los buffer los interpreto como PAnsyChar para ahorrar espacio de memoria (son la mitad que PWCHAR)

 

CreateProcess también debería cambiarse a CreateProcessA puesto que utiliza cadenas de caracteres. Subo unos cambios y aprovecho para introducir SysToUTF8 para que los caracteres acentuados aparezcan correctamente.

 

Si Lazarus 64 protesta con GetStartupInfo / STARTUPINFO, debe usarse la versión A de la estructura STARTUPINFO y de la API GetStartupInfo (Ambas deben ser versión A). La versión Lazarus 32 no protesta. Así mismo todas las variables tipo CHAR o PCHAR deben cambiarse a PAnsiChar, puesto que el compilador puede considerarlas por defecto como WCHAR y PWCHAR. Bajo mi punto de vista considero un error que el compilador interprete estos tipos, pero en delphi Berlin también ocurre. Si definimos como CHAR así debería entenderlo el compilador, es decir un tamaño de 1 byte, si el desarrollador quisiera un WCHAR ya lo especificaría así. Hay que tragarse lo que nos imponen aunque ha generado gran controversia e incompatibilidad de código.


delphi
  1. unit PipeShell2;
  2.  
  3.  
  4. interface
  5.  
  6. uses
  7. Windows, Messages, SysUtils, FileUtil, Classes;
  8.  
  9. const
  10. BUFFERSIZE = 4*1024;
  11.  
  12. type
  13. TPipeShell = class
  14. private
  15. PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
  16. hProcess: THANDLE;
  17. Buffer: PAnsiChar;
  18. protected
  19. public
  20. constructor Create;
  21. destructor Destroy; override;
  22. function Write(S: String): DWORD;
  23. function Read: String;
  24. end;
  25.  
  26. implementation
  27.  
  28. constructor TPipeShell.Create;
  29. var
  30. sd: SECURITY_DESCRIPTOR;
  31. sa: SECURITY_ATTRIBUTES;
  32. si: STARTUPINFO;
  33. pi: PROCESS_INFORMATION;
  34. begin
  35. PipeIn:= 0;
  36. PipeOut:= 0;
  37. PipeWrite:= 0;
  38. PipeRead:= 0;
  39. hProcess:= 0;
  40.  
  41. GetMem(Buffer, BUFFERSIZE);
  42. InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  43. sa.lpSecurityDescriptor:= @sd;
  44. // sa.lpSecurityDescriptor:= nil;
  45. sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  46. sa.bInheritHandle:= TRUE;
  47. // Tuberia de entrada
  48. if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  49. begin
  50. // Tuberia de salida
  51. if CreatePipe(PipeRead, PipeOut, @sa, 0) then
  52. begin
  53. GetStartupInfo(Si);
  54. // Indicamos tuberias del proceso
  55. si.hStdOutput:= PipeOut;
  56. si.hStdError:= PipeOut;
  57. si.hStdInput:= PipeIn;
  58. si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  59. si.wShowWindow:= SW_HIDE;
  60. //si.wShowWindow:= SW_SHOW;
  61. // Ruta del shell
  62. ZeroMemory(Buffer, BUFFERSIZE);
  63. GetEnvironmentVariableA('COMSPEC', Buffer, BUFFERSIZE - 1);
  64. // Ejecutamos el shell
  65. if CreateProcessA(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi) then
  66. begin
  67. hProcess:= pi.hProcess;
  68. CloseHandle(pi.hThread);
  69. end;
  70. end;
  71. end;
  72. end;
  73.  
  74. destructor TPipeShell.Destroy;
  75. var
  76. ExitCode: DWORD;
  77. begin
  78. // Tratamos de terminar el shell
  79. repeat
  80. Write('quit'); Read;
  81. Write('q'); Read;
  82. Write('exit'); Read;
  83. GetExitCodeProcess(hProcess, ExitCode);
  84. until ExitCode <> STILL_ACTIVE;
  85.  
  86. if PipeIn <> 0 then CloseHandle(PipeIn);
  87. if PipeOut <> 0 then CloseHandle(PipeOut);
  88. if PipeWrite <> 0 then CloseHandle(PipeWrite);
  89. if PipeRead <> 0 then CloseHandle(PipeRead);
  90. if hProcess <> 0 then CloseHandle(hProcess);
  91. if Buffer <> nil then FreeMem(Buffer);
  92. if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
  93. TerminateProcess(hProcess, DWORD(-1));
  94. //GetExitCodeProcess(hProcess, ExitCode);
  95. //inherited;
  96. end;
  97.  
  98. function TPipeShell.Write(S: String): DWORD;
  99. begin
  100. if PipeWrite = 0 then exit;
  101. lstrcpy(Buffer, PAnsiCHAR(S + #10));
  102. WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
  103. end;
  104.  
  105. function TPipeShell.Read: String;
  106. var
  107. dwRead, dwBytesAvail: DWORD;
  108. begin
  109. if PipeRead = 0 then exit;
  110.  
  111. dwRead:= 0;
  112. // Esperamos a que tengamos algo que leer en PipeRead
  113. repeat
  114. sleep(100);
  115. PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
  116. if dwRead > 0 then
  117. begin
  118. // Leemos y vaciamos el PipeRead
  119. ZeroMemory(Buffer, BUFFERSIZE);
  120. ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
  121. OemToCharBuffA(Buffer, Buffer, dwRead);
  122. Result:= Result + SysToUTF8(Buffer);
  123. end;
  124. until dwBytesAvail = 0;
  125. end;
  126.  
  127. end.

Si Delphius puede probar con una versión 64bit nativa, mejor.

 

 

Saludos.


  • 1

#15 egostar

egostar

    missing my father, I love my mother.

  • Administrador
  • 13.954 mensajes
  • LocationMéxico

Escrito 12 diciembre 2016 - 11:31

No tengo Lazarus 64 v1.6.2 (para instalarlo tengo que eliminar la versión 32bits) pero he hecho cross compiler 32->64 con el código publicado y sigue compilando y ejecutando correctamente la versión 64 del ejemplo.

 

Es posible que la versión Lazarus 64 esté más enfocada a UNICODE y por eso aparezcan errores que no puedo reproducir. En ese caso conviene usar las versiones A de la API, puesto que los buffer los interpreto como PAnsyChar para ahorrar espacio de memoria (son la mitad que PWCHAR)

 

CreateProcess también debería cambiarse a CreateProcessA puesto que utiliza cadenas de caracteres. Subo unos cambios y aprovecho para introducir SysToUTF8 para que los caracteres acentuados aparezcan correctamente.

 

Si Lazarus 64 protesta con GetStartupInfo / STARTUPINFO, debe usarse la versión A de la estructura STARTUPINFO y de la API GetStartupInfo (Ambas deben ser versión A). La versión Lazarus 32 no protesta. Así mismo todas las variables tipo CHAR o PCHAR deben cambiarse a PAnsiChar, puesto que el compilador puede considerarlas por defecto como WCHAR y PWCHAR. Bajo mi punto de vista considero un error que el compilador interprete estos tipos, pero en delphi Berlin también ocurre. Si definimos como CHAR así debería entenderlo el compilador, es decir un tamaño de 1 byte, si el desarrollador quisiera un WCHAR ya lo especificaría así. Hay que tragarse lo que nos imponen aunque ha generado gran controversia e incompatibilidad de código.

 

 

Destaco lo que comenta nuestru buen amigo escafandra porque me parece muy puntual, interesante y didático.

 

Saludos


  • 1

#16 Delphius

Delphius

    Advanced Member

  • Administrador
  • 6.258 mensajes
  • LocationArgentina

Escrito 12 diciembre 2016 - 12:45

En un rato me pongo a probar que me salta a mi.

 

Saludos,


  • 0

#17 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 12 diciembre 2016 - 12:54

egostar celebro que estés de acuerdo conmigo.

Saludos
  • 0

#18 Delphius

Delphius

    Advanced Member

  • Administrador
  • 6.258 mensajes
  • LocationArgentina

Escrito 12 diciembre 2016 - 12:57

Efectivamente si abro el archivo lazarus.rar que adjuntaste en el mensaje #8 y lo compilo con CodeTyphon 5.6 en 64bits alerta de los tipos:

 

 

Compilar proyecto, Objetivo: project1.exe: Código de salida 1, Errores: 2, Advertencias: 1, Sugerencias: 5
PipeShell2.pas(53,24) Error: Call by var for arg no. 1 has to match exactly: Got "STARTUPINFO" expected "STARTUPINFOA"
redef.inc(586,11) Hint: Found declaration: GetStartupInfo(var STARTUPINFOA);
ascdef.inc(360,11) Hint: Found declaration: GetStartupInfo(LPSTARTUPINFOA);
PipeShell2.pas(65,85) Error: Incompatible type for arg no. 9: Got "STARTUPINFO", expected "STARTUPINFOA"
redef.inc(339,10) Hint: Found declaration: CreateProcess(PChar;PChar;PSECURITYATTRIBUTES;PSECURITYATTRIBUTES;LongBool;LongWord;Pointer;PChar;const STARTUPINFOA;var PROCESS_INFORMATION):LongBool;
ascdef.inc(358,10) Hint: Found declaration: CreateProcess(PChar;PChar;LPSECURITY_ATTRIBUTES;LPSECURITY_ATTRIBUTES;LongBool;LongWord;Pointer;PChar;LPSTARTUPINFOA;LPPROCESS_INFORMATION):LongBool;
PipeShell2.pas(102,56) Hint: Function result variable does not seem to be initialized
PipeShell2.pas(122,23) Warning: function result variable of a managed type does not seem to be initialized

 

Probaré con los cambios oportunos que pusiste en el mensaje #14.

 

Saludos,


  • 0

#19 Delphius

Delphius

    Advanced Member

  • Administrador
  • 6.258 mensajes
  • LocationArgentina

Escrito 12 diciembre 2016 - 01:32

Al realizar cambios como en la respuesta #14 del compañero escafandra, me seguía alertando sobre el tipo. Esta vez, empezó a sugerirme que se cambie por LPSTARTUPINFOA.

 

Así que efectué los siguientes cambios:


delphi
  1. unit PipeShell2;
  2.  
  3.  
  4. interface
  5.  
  6. uses
  7. Windows, Messages, SysUtils, FileUtil, Classes, LazUTF8;
  8.  
  9. const
  10. BUFFERSIZE = 4*1024;
  11.  
  12. type
  13. TPipeShell = class
  14. private
  15. PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
  16. hProcess: THANDLE;
  17. Buffer: PAnsiChar;
  18. protected
  19. public
  20. constructor Create;
  21. destructor Destroy; override;
  22. function Write(S: String): DWORD;
  23. function Read: String;
  24. end;
  25.  
  26. implementation
  27.  
  28. constructor TPipeShell.Create;
  29. var
  30. sd: SECURITY_DESCRIPTOR;
  31. sa: SECURITY_ATTRIBUTES;
  32. si: LPSTARTUPINFOA; // Se cambió el tipo!
  33. pi: PROCESS_INFORMATION;
  34. begin
  35. PipeIn:= 0;
  36. PipeOut:= 0;
  37. PipeWrite:= 0;
  38. PipeRead:= 0;
  39. hProcess:= 0;
  40.  
  41. GetMem(Buffer, BUFFERSIZE);
  42. InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  43. sa.lpSecurityDescriptor:= @sd;
  44. // sa.lpSecurityDescriptor:= nil;
  45. sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  46. sa.bInheritHandle:= TRUE;
  47. // Tuberia de entrada
  48. if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  49. begin
  50. // Tuberia de salida
  51. if CreatePipe(PipeRead, PipeOut, @sa, 0) then
  52. begin
  53. GetStartupInfoA(Si); // Se invoca a la versión "A"
  54. // Indicamos tuberias del proceso
  55. // Acá otros cambios. Se debe usar si^. ya que el "LP" es un puntero a STARTUPINFOA
  56. si^.hStdOutput:= PipeOut;
  57. si^.hStdError:= PipeOut;
  58. si^.hStdInput:= PipeIn;
  59. si^.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  60. si^.wShowWindow:= SW_HIDE;
  61. //si.wShowWindow:= SW_SHOW;
  62. // Ruta del shell
  63. ZeroMemory(Buffer, BUFFERSIZE);
  64. GetEnvironmentVariableA('COMSPEC', Buffer, BUFFERSIZE - 1);
  65. // Ejecutamos el shell
  66. // Otro cambio en la siguiente línea: como se pasa en realidad a lo que apunta si
  67. // ya que CreateProcessA espera el STARTUPINFOA y no el LPSTARTUPINFOA
  68. if CreateProcessA(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si^, pi) then
  69. begin
  70. hProcess:= pi.hProcess;
  71. CloseHandle(pi.hThread);
  72. end;
  73. end;
  74. end;
  75. end;
  76.  
  77. destructor TPipeShell.Destroy;
  78. var
  79. ExitCode: DWORD;
  80. begin
  81. // Tratamos de terminar el shell
  82. repeat
  83. Write('quit'); Read;
  84. Write('q'); Read;
  85. Write('exit'); Read;
  86. GetExitCodeProcess(hProcess, ExitCode);
  87. until ExitCode <> STILL_ACTIVE;
  88.  
  89. if PipeIn <> 0 then CloseHandle(PipeIn);
  90. if PipeOut <> 0 then CloseHandle(PipeOut);
  91. if PipeWrite <> 0 then CloseHandle(PipeWrite);
  92. if PipeRead <> 0 then CloseHandle(PipeRead);
  93. if hProcess <> 0 then CloseHandle(hProcess);
  94. if Buffer <> nil then FreeMem(Buffer);
  95. if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
  96. TerminateProcess(hProcess, DWORD(-1));
  97. //GetExitCodeProcess(hProcess, ExitCode);
  98. //inherited;
  99. end;
  100.  
  101. function TPipeShell.Write(S: String): DWORD;
  102. begin
  103. if PipeWrite = 0 then exit;
  104. lstrcpy(Buffer, PAnsiCHAR(S + #10));
  105. WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
  106. end;
  107.  
  108. function TPipeShell.Read: String;
  109. var
  110. dwRead, dwBytesAvail: DWORD;
  111. begin
  112. if PipeRead = 0 then exit;
  113.  
  114. dwRead:= 0;
  115. // Esperamos a que tengamos algo que leer en PipeRead
  116. repeat
  117. sleep(100);
  118. PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
  119. if dwRead > 0 then
  120. begin
  121. // Leemos y vaciamos el PipeRead
  122. ZeroMemory(Buffer, BUFFERSIZE);
  123. ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
  124. OemToCharBuffA(Buffer, Buffer, dwRead);
  125. //Result:= Result + SysToUTF8(Buffer);
  126. Result := Result + LazUTF8.SysToUTF8(Buffer);
  127. end;
  128. until dwBytesAvail = 0;
  129. end;
  130.  
  131. end.

A pesar de estos cambios el compilador pasó la prueba, con algunos warnings menores.

PERO al momento de ejecutar obtengo un Access Violation. Confirmo y me deja ejecutar y probar la aplicación. Hago la prueba que muestra en su imagen escafandra y obtengo otro AV más. Esta vez ya el compilador protesta, detengo y observo en la venta de mensajes:


delphi
  1. Ventana de Mensajes, Errores: 2
  2. Error: El proyecto project1 ha lanzado una excepción de la clase 'External: SIGSEGV'.
  3.  
  4. en dirección 7FFB1F6728AE
  5. Error: El proyecto project1 ha lanzado una excepción de la clase 'External: SIGSEGV'.
  6.  
  7. En archivo 'PipeShell2.pas' en linea 100:
  8. if PipeWrite = 0 then exit;

Ahí ya me mató.

No se que hice mal :(


delphi
  1. function TPipeShell.Write(S: String): DWORD;
  2. begin
  3. if PipeWrite = 0 then exit;
  4. lstrcpy(Buffer, PAnsiCHAR(S + #10));
  5. WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
  6. end;

El error como lo dice el mensaje, está en el if PipeWrite.

El problema de este tipo de error que se da a nivel del compilador es que es genérico. No da una descripción efectiva de su causa.

Creería que el problema está nuevamente en los tipos... esta vez en las variaciones de los word...

 

En un equipo de 64bits el tipo THandle (la variable PipeWrite) es un alias:


delphi
  1. THandle = System.THandle;

que está definido en classesh.inc, y este System.THandle es a su vez definido (en sysosh.inc) según la arquitectura:


delphi
  1. {$ifdef CPU64}
  2. THandle = QWord;
  3. ULONG_PTR = QWord;
  4. {$else CPU64}
  5. THandle = DWord;
  6. ULONG_PTR = DWord;
  7. {$endif CPU64}
  8. TThreadID = THandle;
  9. SIZE_T = ULONG_PTR;

¿Será que debo tratar y comparar este 0 con si fuera un QWord? ¿Como un cast hacia este tipo?

Me ha dejado con más dudas la verdad.

 

Saludos,


  • 0

#20 escafandra

escafandra

    Advanced Member

  • Moderadores
  • PipPipPip
  • 3.842 mensajes
  • LocationMadrid - España

Escrito 12 diciembre 2016 - 01:35

Efectivamente si abro el archivo lazarus.rar que adjuntaste en el mensaje #8 y lo compilo con CodeTyphon 5.6 en 64bits alerta de los tipos:
 
 
Probaré con los cambios oportunos que pusiste en el mensaje #14.
 
Saludos,


A esos cambios añade STARTUPINFOA y GetStartupInfoA.


Saludos.
  • 0





Etiquetado también con una o más de estas palabras: Automatización, Procesos, Consola