26 replies to this topic

[Edson]

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.

[escafandra]

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

:
 

delphi

function CmdConsoleCommand(CommandLine: String): String;
var
  Buffer: array [0..4096] of char;
  pipeRead, pipeWrite: THandle;
  sa: SECURITY_ATTRIBUTES;
  si: STARTUPINFO;
  pi: PROCESS_INFORMATION;
  dwRead: DWORD;
begin
  Result:= '';
  if CommandLine[2] = ':' then
      SetCurrentDirectory(PCHAR(CommandLine));
 
  // Ejecuto comando y devuelvo resultado
  GetEnvironmentVariable('COMSPEC', @Buffer[0], sizeof(Buffer));
  lstrcat(Buffer, ' /C ');
  lstrcat(Buffer, PCHAR(CommandLine));
  ZeroMemory(@sa, sizeof(SECURITY_ATTRIBUTES));
  sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  sa.bInheritHandle:= TRUE;
 
  if CreatePipe(pipeRead, pipeWrite, @sa, 25*1024) then
  begin
    ZeroMemory(@si, sizeof(STARTUPINFO));
    si.cb:= sizeof(STARTUPINFO);
    ZeroMemory(@pi, sizeof(PROCESS_INFORMATION));
    si.hStdOutput:= pipeWrite;
    si.hStdError := pipeWrite;
    si.hStdInput := pipeWrite;
    si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    si.wShowWindow:= SW_HIDE;
 
    if CreateProcess(0, @Buffer[0], 0, 0, TRUE, 0, 0, 0, si, pi) then
    begin
      CloseHandle(pi.hThread);
      if WaitForSingleObject(pi.hProcess, 9000) = WAIT_OBJECT_0 then
      begin
        dwRead:= 0;
        Buffer[0]:= ' ';   // un espacio
        WriteFile(pipeWrite, Buffer[0], 1, dwRead, 0);
        repeat
          ZeroMemory(@Buffer[0], sizeof(Buffer));
          ReadFile(pipeRead, Buffer, sizeof(Buffer), dwRead, 0);
          OemToCharBuffA(Buffer, Buffer, dwRead);
          Result:= Result + String(Buffer);
        until dwRead <= sizeof(Buffer);
      end; //WaitForSingleObject
      CloseHandle(pi.hProcess);
    end; //CreateProcess
    CloseHandle(pipeRead);
    CloseHandle(pipeWrite);
  end; //CreatePipe
end;

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

Saludos.

[Edson]

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

[escafandra]

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

 

 

Saludos.

[Edson]

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.

[escafandra]

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

unit PipeShell2;
 
 
interface
 
uses
  Windows, Messages, SysUtils, Classes;
 
const
  BUFFERSIZE = 4*1024;
 
type
  TPipeShell = class
  private
    PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
    hProcess: THANDLE;
    Buffer: PAnsiChar;
  protected
  public
    constructor Create;
    destructor  Destroy; override;
    function Write(S: String): DWORD;
    function Read: String;
  end;
 
implementation
 
constructor TPipeShell.Create;
var
  sa: SECURITY_ATTRIBUTES;
  si: STARTUPINFO;
  pi: PROCESS_INFORMATION;
begin
  PipeIn:= 0;
  PipeOut:= 0;
  PipeWrite:= 0;
  PipeRead:= 0;
  hProcess:= 0;
 
  GetMem(Buffer, BUFFERSIZE);
 
  sa.lpSecurityDescriptor:= nil;
  sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  sa.bInheritHandle := TRUE;
  // Tuberia de entrada
  if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  begin
    // Tuberia de salida
    if CreatePipe(PipeRead, PipeOut, @sa, 0) then
    begin
      GetStartupInfo(Si);
      // Indicamos tuberias del proceso
      si.hStdOutput:= PipeOut;
      si.hStdError:= PipeOut;
      si.hStdInput:= PipeIn;
      si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      si.wShowWindow:= SW_HIDE;
      //si.wShowWindow:= SW_SHOW;
      // Ruta del shell
      ZeroMemory(Buffer, BUFFERSIZE);
      GetEnvironmentVariable('COMSPEC', Buffer, BUFFERSIZE - 1);
      // Ejecutamos el shell
      if CreateProcess(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi) then
      begin
         hProcess:= pi.hProcess;
         CloseHandle(pi.hThread);
      end;
    end;
  end;
end;
 
destructor TPipeShell.Destroy;
var
  ExitCode: DWORD;
begin
  // Tratamos de terminar el shell
  Write('quit');
  Write('exit');
  if PipeIn <> 0    then CloseHandle(PipeIn);
  if PipeOut <> 0   then CloseHandle(PipeOut);
  if PipeWrite <> 0 then CloseHandle(PipeWrite);
  if PipeRead <> 0  then CloseHandle(PipeRead);
  if hProcess <> 0  then CloseHandle(hProcess);
  if Buffer <> nil  then FreeMem(Buffer);
  if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
    TerminateProcess(hProcess, DWORD(-1));
  //GetExitCodeProcess(hProcess, ExitCode);
  //inherited;
end;
 
function TPipeShell.Write(S: String): DWORD;
begin
  lstrcpy(Buffer, PCHAR(S + #10));
  WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
end;
 
function TPipeShell.Read: String;
var
  dwRead, dwBytesAvail: DWORD;
begin
  dwRead:= 0;
  // Esperamos a que tengamos algo que leer en PipeRead
  repeat
    sleep(100);
    PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
  until dwRead > 0;
  // Leemos y vaciamos el PipeRead
  ZeroMemory(Buffer, BUFFERSIZE);
  ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
  OemToCharBuffA(Buffer, Buffer, dwRead);
  Result:= String(Buffer);
end;
 
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

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, PipeShell2;
 
type
  TForm3 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
  private
    PipeShell: TPipeShell;
  public
    { Public declarations }
  end;
 
var
  Form3: TForm3;
 
implementation
 
{$R *.dfm}
 
procedure TForm3.FormCreate(Sender: TObject);
begin
  PipeShell:= TPipeShell.Create;
  Memo1.Text:= PipeShell.Read;
end;
 
procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  PipeShell.Free;
end;
 
procedure TForm3.Button1Click(Sender: TObject);
begin
  PipeShell.Write(Edit1.Text);
  Memo1.Text:= StringReplace(PipeShell.Read, #10, #13+#10, [rfReplaceAll]);
end;
 
end.

 

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

Attached Files

•  PipeShell.jpg   26.15KB   1 downloads
•  PipeShell.rar   161.5KB   20 downloads

[Edson]

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

 

Gracias.

[escafandra]

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

delphi

unit PipeShell2;
 
 
interface
 
uses
  Windows, Messages, SysUtils, Classes;
 
const
  BUFFERSIZE = 4*1024;
 
type
  TPipeShell = class
  private
    PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
    hProcess: THANDLE;
    Buffer: PAnsiChar;
  protected
  public
    constructor Create;
    destructor  Destroy; override;
    function Write(S: String): DWORD;
    function Read: String;
  end;
 
implementation
 
constructor TPipeShell.Create;
var
  sd: SECURITY_DESCRIPTOR;
  sa: SECURITY_ATTRIBUTES;
  si: STARTUPINFO;
  pi: PROCESS_INFORMATION;
begin
  PipeIn:= 0;
  PipeOut:= 0;
  PipeWrite:= 0;
  PipeRead:= 0;
  hProcess:= 0;
 
  GetMem(Buffer, BUFFERSIZE);
  InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  sa.lpSecurityDescriptor:= @sd;
//  sa.lpSecurityDescriptor:= nil;
  sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  sa.bInheritHandle:= TRUE;
  // Tuberia de entrada
  if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  begin
    // Tuberia de salida
    if CreatePipe(PipeRead, PipeOut, @sa, 0) then
    begin
      GetStartupInfo(Si);
      // Indicamos tuberias del proceso
      si.hStdOutput:= PipeOut;
      si.hStdError:= PipeOut;
      si.hStdInput:= PipeIn;
      si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      si.wShowWindow:= SW_HIDE;
      //si.wShowWindow:= SW_SHOW;
      // Ruta del shell
      ZeroMemory(Buffer, BUFFERSIZE);
      GetEnvironmentVariableA('COMSPEC', Buffer, BUFFERSIZE - 1);
      // Ejecutamos el shell
      if CreateProcess(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi) then
      begin
         hProcess:= pi.hProcess;
         CloseHandle(pi.hThread);
      end;
    end;
  end;
end;
 
destructor TPipeShell.Destroy;
var
  ExitCode: DWORD;
begin
  // Tratamos de terminar el shell
  repeat
    Write('quit'); Read;
    Write('q'); Read;
    Write('exit'); Read;
    GetExitCodeProcess(hProcess, ExitCode);
  until ExitCode <> STILL_ACTIVE;
 
  if PipeIn <> 0    then CloseHandle(PipeIn);
  if PipeOut <> 0   then CloseHandle(PipeOut);
  if PipeWrite <> 0 then CloseHandle(PipeWrite);
  if PipeRead <> 0  then CloseHandle(PipeRead);
  if hProcess <> 0  then CloseHandle(hProcess);
  if Buffer <> nil  then FreeMem(Buffer);
  if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
    TerminateProcess(hProcess, DWORD(-1));
  //GetExitCodeProcess(hProcess, ExitCode);
  //inherited;
end;
 
function TPipeShell.Write(S: String): DWORD;
begin
  if PipeWrite = 0 then exit;
  lstrcpy(Buffer, PCHAR(S + #10));
  WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
end;
 
function TPipeShell.Read: String;
var
  dwRead, dwBytesAvail: DWORD;
begin
  if PipeRead = 0 then exit;
 
  dwRead:= 0;
  // Esperamos a que tengamos algo que leer en PipeRead
  repeat
    sleep(100);
    PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
    if dwRead > 0 then
    begin
      // Leemos y vaciamos el PipeRead
      ZeroMemory(Buffer, BUFFERSIZE);
      ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
      OemToCharBuffA(Buffer, Buffer, dwRead);
      Result:= Result + String(Buffer);
    end;
  until dwBytesAvail = 0;
end;  
 
end.

Subo proyecto delphi y Lazarus.

 

 

Saludos.

Attached Files

•  PipeShell.rar   161.84KB   15 downloads
•  lazarus.rar   124.84KB   12 downloads

[Edson]

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

      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.

[Delphius]

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

      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,

[Edson]

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.

[escafandra]

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.

[Delphius]

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,

[escafandra]

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

unit PipeShell2;
 
 
interface
 
uses
  Windows, Messages, SysUtils, FileUtil, Classes;
 
const
  BUFFERSIZE = 4*1024;
 
type
  TPipeShell = class
  private
    PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
    hProcess: THANDLE;
    Buffer: PAnsiChar;
  protected
  public
    constructor Create;
    destructor  Destroy; override;
    function Write(S: String): DWORD;
    function Read: String;
  end;
 
implementation
 
constructor TPipeShell.Create;
var
  sd: SECURITY_DESCRIPTOR;
  sa: SECURITY_ATTRIBUTES;
  si: STARTUPINFO;
  pi: PROCESS_INFORMATION;
begin
  PipeIn:= 0;
  PipeOut:= 0;
  PipeWrite:= 0;
  PipeRead:= 0;
  hProcess:= 0;
 
  GetMem(Buffer, BUFFERSIZE);
  InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  sa.lpSecurityDescriptor:= @sd;
//  sa.lpSecurityDescriptor:= nil;
  sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  sa.bInheritHandle:= TRUE;
  // Tuberia de entrada
  if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  begin
    // Tuberia de salida
    if CreatePipe(PipeRead, PipeOut, @sa, 0) then
    begin
      GetStartupInfo(Si);
      // Indicamos tuberias del proceso
      si.hStdOutput:= PipeOut;
      si.hStdError:= PipeOut;
      si.hStdInput:= PipeIn;
      si.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      si.wShowWindow:= SW_HIDE;
      //si.wShowWindow:= SW_SHOW;
      // Ruta del shell
      ZeroMemory(Buffer, BUFFERSIZE);
      GetEnvironmentVariableA('COMSPEC', Buffer, BUFFERSIZE - 1);
      // Ejecutamos el shell
      if CreateProcessA(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si, pi) then
      begin
         hProcess:= pi.hProcess;
         CloseHandle(pi.hThread);
      end;
    end;
  end;
end;
 
destructor TPipeShell.Destroy;
var
  ExitCode: DWORD;
begin
  // Tratamos de terminar el shell
  repeat
    Write('quit'); Read;
    Write('q'); Read;
    Write('exit'); Read;
    GetExitCodeProcess(hProcess, ExitCode);
  until ExitCode <> STILL_ACTIVE;
 
  if PipeIn <> 0    then CloseHandle(PipeIn);
  if PipeOut <> 0   then CloseHandle(PipeOut);
  if PipeWrite <> 0 then CloseHandle(PipeWrite);
  if PipeRead <> 0  then CloseHandle(PipeRead);
  if hProcess <> 0  then CloseHandle(hProcess);
  if Buffer <> nil  then FreeMem(Buffer);
  if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
    TerminateProcess(hProcess, DWORD(-1));
  //GetExitCodeProcess(hProcess, ExitCode);
  //inherited;
end;
 
function TPipeShell.Write(S: String): DWORD;
begin
  if PipeWrite = 0 then exit;
  lstrcpy(Buffer, PAnsiCHAR(S + #10));
  WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
end;
 
function TPipeShell.Read: String;
var
  dwRead, dwBytesAvail: DWORD;
begin
  if PipeRead = 0 then exit;
 
  dwRead:= 0;
  // Esperamos a que tengamos algo que leer en PipeRead
  repeat
    sleep(100);
    PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
    if dwRead > 0 then
    begin
      // Leemos y vaciamos el PipeRead
      ZeroMemory(Buffer, BUFFERSIZE);
      ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
      OemToCharBuffA(Buffer, Buffer, dwRead);
      Result:= Result + SysToUTF8(Buffer);
    end;
  until dwBytesAvail = 0;
end;
 
end.

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

 

 

Saludos.

[egostar]

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

[Delphius]

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

 

Saludos,

[escafandra]

egostar celebro que estés de acuerdo conmigo.

Saludos

[Delphius]

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,

[Delphius]

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

unit PipeShell2;
 
 
interface
 
uses
  Windows, Messages, SysUtils, FileUtil, Classes, LazUTF8;
 
const
  BUFFERSIZE = 4*1024;
 
type
  TPipeShell = class
  private
    PipeIn, PipeOut, PipeWrite, PipeRead: THANDLE;
    hProcess: THANDLE;
    Buffer: PAnsiChar;
  protected
  public
    constructor Create;
    destructor  Destroy; override;
    function Write(S: String): DWORD;
    function Read: String;
  end;
 
implementation
 
constructor TPipeShell.Create;
var
  sd: SECURITY_DESCRIPTOR;
  sa: SECURITY_ATTRIBUTES;
  si: LPSTARTUPINFOA; // Se cambió el tipo!
  pi: PROCESS_INFORMATION;
begin
  PipeIn:= 0;
  PipeOut:= 0;
  PipeWrite:= 0;
  PipeRead:= 0;
  hProcess:= 0;
 
  GetMem(Buffer, BUFFERSIZE);
  InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  sa.lpSecurityDescriptor:= @sd;
//  sa.lpSecurityDescriptor:= nil;
  sa.nLength:= sizeof(SECURITY_ATTRIBUTES);
  sa.bInheritHandle:= TRUE;
  // Tuberia de entrada
  if CreatePipe(PipeIn, PipeWrite, @sa, 0) then
  begin
    // Tuberia de salida
    if CreatePipe(PipeRead, PipeOut, @sa, 0) then
    begin
      GetStartupInfoA(Si); // Se invoca a la versión "A"
      // Indicamos tuberias del proceso
      // Acá otros cambios. Se debe usar si^. ya que el "LP" es un puntero a STARTUPINFOA
      si^.hStdOutput:= PipeOut;
      si^.hStdError:= PipeOut;
      si^.hStdInput:= PipeIn;
      si^.dwFlags:= STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
      si^.wShowWindow:= SW_HIDE;
      //si.wShowWindow:= SW_SHOW;
      // Ruta del shell
      ZeroMemory(Buffer, BUFFERSIZE);
      GetEnvironmentVariableA('COMSPEC', Buffer, BUFFERSIZE - 1);
      // Ejecutamos el shell
      // Otro cambio en la siguiente línea: como se pasa en realidad a lo que apunta si
      // ya que CreateProcessA espera el STARTUPINFOA y no el LPSTARTUPINFOA 
      if CreateProcessA(nil, Buffer, nil, nil, TRUE, CREATE_NEW_CONSOLE, nil, nil, si^, pi) then
      begin
         hProcess:= pi.hProcess;
         CloseHandle(pi.hThread);
      end;
    end;
  end;
end;
 
destructor TPipeShell.Destroy;
var
  ExitCode: DWORD;
begin
  // Tratamos de terminar el shell
  repeat
    Write('quit'); Read;
    Write('q'); Read;
    Write('exit'); Read;
    GetExitCodeProcess(hProcess, ExitCode);
  until ExitCode <> STILL_ACTIVE;
 
  if PipeIn <> 0    then CloseHandle(PipeIn);
  if PipeOut <> 0   then CloseHandle(PipeOut);
  if PipeWrite <> 0 then CloseHandle(PipeWrite);
  if PipeRead <> 0  then CloseHandle(PipeRead);
  if hProcess <> 0  then CloseHandle(hProcess);
  if Buffer <> nil  then FreeMem(Buffer);
  if WaitForSingleObject(hProcess, 9000) <> WAIT_OBJECT_0 then
    TerminateProcess(hProcess, DWORD(-1));
  //GetExitCodeProcess(hProcess, ExitCode);
  //inherited;
end;
 
function TPipeShell.Write(S: String): DWORD;
begin
  if PipeWrite = 0 then exit;
  lstrcpy(Buffer, PAnsiCHAR(S + #10));
  WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
end;
 
function TPipeShell.Read: String;
var
  dwRead, dwBytesAvail: DWORD;
begin
  if PipeRead = 0 then exit;
 
  dwRead:= 0;
  // Esperamos a que tengamos algo que leer en PipeRead
  repeat
    sleep(100);
    PeekNamedPipe(PipeRead, Buffer, BUFFERSIZE, @dwRead, @dwBytesAvail, nil);
    if dwRead > 0 then
    begin
      // Leemos y vaciamos el PipeRead
      ZeroMemory(Buffer, BUFFERSIZE);
      ReadFile(PipeRead, Buffer^, dwRead, PDWORD(0)^, nil);
      OemToCharBuffA(Buffer, Buffer, dwRead);
      //Result:= Result + SysToUTF8(Buffer);
      Result := Result + LazUTF8.SysToUTF8(Buffer);
    end;
  until dwBytesAvail = 0;
end;
 
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

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

Ahí ya me mató.

No se que hice mal

delphi

function TPipeShell.Write(S: String): DWORD;
begin
  if PipeWrite = 0 then exit;
  lstrcpy(Buffer, PAnsiCHAR(S + #10));
  WriteFile(PipeWrite, Buffer^, lstrlen(Buffer), Result, nil);
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

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

{$ifdef CPU64}
  THandle = QWord;
  ULONG_PTR = QWord;
{$else CPU64}
  THandle = DWord;
  ULONG_PTR = DWord;
{$endif CPU64}
  TThreadID = THandle;
  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,

[escafandra]

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.