Ru-Board.club
← Вернуться в раздел «Прикладное программирование»

» Delphi: "Оболочка" для консольного приложения

Автор: Phoenix555
Дата сообщения: 13.06.2006 15:40
в общем надо реализовать программу точно такую же по принципу работы: http://www.felix-colibri.com/scripts/fcolibri.exe?a=1?filename=console_read_write.zip

но лучше с графическим интерефейсом ...
т.е чтобы ввод брался из TEdit, а результат выводился в TMemo

срочно нужно ....
Автор: Phoenix555
Дата сообщения: 19.06.2006 11:25
в "соседнем" топике нашел ссылку на решение
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/creating_a_child_process_with_redirected_input_and_output.asp
но .. в Си не силен, а вернее мне вообще не понятен синтаксис ...
кому не лень .. плз сделайте перевод на "нормальный" язык програмирования(т.е Object pascal) ... шутка .. но в каждой шутке есть доля шутки

Добавлено:
вот перенаправил вывод в TMemo в режиме реального времени, но отправить данные в консоль не получается .. кто-нибудь! подскажите где ошибка плз:
[more]
cons.pas

Код:
unit cons;

interface

uses
Windows, Classes,Forms,sysutils, ExtCtrls, ScktComp,
Sockets, Controls, StdCtrls,dialogs,th;

type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
Edit1: TEdit;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure cmd;
//------------------------------------
private
{ Private declarations }
public
{ Public declarations }
si: STARTUPINFO;
sa: PSecurityAttributes;
sd: SECURITY_DESCRIPTOR;
pi: PROCESS_INFORMATION;
outRead,inRead,outWrite,inWrite: tHANDLE;
buf: array [0..1024] of char;
end;
var
Form1: TForm1;
thrc:thr;
implementation

{$R *.dfm}
//------------------------------------------------------------------------------
function WinToDos(St: string): string;
var
Ch: PChar;
begin
Ch := StrAlloc(Length(St) + 1);
AnsiToOem(PChar(St), Ch);
Result := Ch;
StrDispose(Ch)
end;
//------------------------------------------------------------------------------
procedure tform1.cmd;
var
DesBufSize: DWORD;
exit:dword;
begin
new(sa);
sa.nLength := sizeof(PSECURITYATTRIBUTES);
sa.bInheritHandle := true;
sa.lpSecurityDescriptor := nil;
CreatePipe (outRead, outWrite, sa, 0);
CreatePipe (inRead, inWrite, sa, 0);
SetHandleInformation(outRead, HANDLE_FLAG_INHERIT, 0);
SetHandleInformation(inWrite, HANDLE_FLAG_INHERIT, 0);
GetStartupInfo(si);
si.cb := sizeof(STARTUPINFO);
si.hStdError := outWrite;
si.hStdOutput := outWrite;
si.hStdInput := inRead;
si.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
si.wShowWindow := 0;
if CreateProcess('c:\windows\system32\cmd.exe',NiL,NiL,NiL,TRUE,CREATE_NEW_CONSOLE,
NiL,NiL,si,pi)=true then
begin
thrc:=thr.Create(true);
thrc.Suspended:=false;
end;
end;
//------------------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var
i, DesBufSize: DWORD;
s:string;
a:array of char;
begin
s:=wintodos(edit1.Text);
setlength(a,length(s));
DesBufSize:=length(s);
for i:=0 to length(s)-1 do a[i]:=s[i];
WriteFile(si.hStdInput,a,length(a),DesBufSize,nil);
end;
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
cmd;
end;
//------------------------------------------------------------------------------
end.
Автор: Phoenix555
Дата сообщения: 19.06.2006 21:04
эх
сюда кто-нить заглядывает хоть ?
Автор: ShIvADeSt
Дата сообщения: 20.06.2006 01:07
слушай я посмотрел код проги который ты дал, там идет обычное чтение с клавиатуры и запись в лог, в чем именно траблы? Если ты не знаешь как из едита добавить в мемо, то так блин и пиши, задача тривиальная, а ты зачем то пайпы приплел.
Memo1.Strings.Add(Edit1.Text);
Данную строку помести в анализатор нажатия клавиши в едите, и если клавиша равна ентеру, то помещай в мемо. Впредь научись правильно формулировать задания.
Автор: vserd
Дата сообщения: 20.06.2006 12:19
Phoenix555
www.delphikingdom.com там есть куча вопросов/ответов по этой теме.
Кроме того есть такой ресурс www.google.com море ответов.
Автор: Phoenix555
Дата сообщения: 20.06.2006 13:15
ShIvADeSt, ошибаешься ...
в данном мной коде поцедура tform1.cmd запускает дочений процесс и запускает еще один поток thr.ExeCute, в котором перехватывает полученные данные из этого дочернего процесса cmd.exe .. далее поток через synchronize(um) выводит их в первый поток ... в наш TMemo на TForm ..
и нету там никакого чтения с клавиатуры ..
для особо догадливых: в этом коде нужно сделать так, чтобы процедура TForm1.Button1Click отправляла содержимое TEdit в input дочернего процесса .... тоесть чтобы когда я введу в него dir и нажму на кнопку данные отпарвились в процесс, а из процесса второй поток получил результат и вывел в TMemo и в нем можно было смотерть содержимое текущей директории
Автор: ShIvADeSt
Дата сообщения: 21.06.2006 03:11
Вот рабочий код по работе с консолью (спасибо КД и Горбань)
[more]
var
Form1: TForm1;

implementation
var
FChildStdoutRd, FChildStdoutWr,FChildStdinRd, FChildStdinWr, Tmp1,Tmp2 :THAndle;

{$R *.DFM}
function CreateChildProcess(ExeName, CommadLine: String; StdIn,
StdOut: THandle): Boolean;
Var
piProcInfo: TProcessInformation;
siStartInfo: TStartupInfo;
begin
// Set up members of STARTUPINFO structure.
ZeroMemory(@siStartInfo, SizeOf(TStartupInfo));
siStartInfo.cb:=SizeOf(TStartupInfo);
siStartInfo.hStdInput:=StdIn;
siStartInfo.hStdOutput:=StdOut;
siStartInfo.dwFlags:=STARTF_USESTDHANDLES;
// Create the child process.
Result:=CreateProcess(Nil,
PChar(ExeName+' '+CommadLine), // command line
Nil, // process security attributes
Nil, // primary thread security attributes
TRUE, // handles are inherited
0, // creation flags
Nil, // use parent's environment
Nil, // use parent's current directory
siStartInfo, // STARTUPINFO pointer
piProcInfo); // receives PROCESS_INFORMATION
end;

procedure NewPipe;
var
FSaAttr SECURITYATTRIBUTES;
begin
New(FsaAttr);
FsaAttr.nLength:=SizeOf(SECURITY_ATTRIBUTES);
FsaAttr.bInheritHandle:=True;
FsaAttr.lpSecurityDescriptor:=Nil;
CreatePipe(FChildStdoutRd, FChildStdoutWr, FsaAttr, 0);
CreatePipe(FChildStdinRd, FChildStdinWr, FsaAttr, 0);
//Делаем НЕ наследуемые дубликаты
//Это нужно, чтобы не тащить лишние хэндлы в дочерний процесс...
DuplicateHandle(GetCurrentProcess(), FChildStdoutRd,
GetCurrentProcess(), @Tmp1, 0, False, DUPLICATE_SAME_ACCESS);
DuplicateHandle(GetCurrentProcess(), FChildStdinWr,
GetCurrentProcess(), @Tmp2, 0, False, DUPLICATE_SAME_ACCESS);
CloseHandle(FChildStdoutRd);//Закроем наследуемый вариант "Читального" хэндла
CloseHandle(FChildStdinWr); //Закроем наследуемый вариант "Писального" хэндла
FChildStdoutRd:=Tmp1; //И воткнем их места НЕ наследуемые дубликаты
FChildStdinWr:=Tmp2; //И воткнем их места НЕ наследуемые дубликаты
CreateChildProcess('cmd.exe', '', FChildStdinRd, FChildStdoutWr)
end;

function WriteToChild(Data: String):
Boolean;
Var
dwWritten, BufSize: DWORD;
chBuf: PChar;
begin
//Обратите внимание на Chr($0D)+Chr($0A)!!! Без них - будет работать с ошибками
//На досуге - подумайте почему...
//Для тех, кому думать лень - подскажу - это пара символов конца строки.
//(вообще-то можно обойтись одним, но так надежнее, программы-то бывают разные)
chBuf:=PChar(Data+Chr($0D)+Chr($0A));
BufSize:=Length(chBuf);
Result:=WriteFile(FChildStdinWr, chBuf^, BufSize, dwWritten, Nil);
Result:=Result and (BufSize = dwWritten);
end;

function ReadStrFromChild(Timeout: Integer): String;
Var
i: Integer;
dwRead, BufSize, DesBufSize: DWORD;
chBuf: PChar;
Res: Boolean;
begin
Try
BufSize:=0;
New(chBuf);
Repeat
For i:=0 to 9 do
begin
Res:=PeekNamedPipe(FChildStdoutRd, nil, 0, nil, @DesBufSize, nil);
Res:=Res and (DesBufSize > 0);
If Res Then
Break;
Sleep(Round(Timeout/10));
end;
If Res Then
begin
If DesBufSize > BufSize Then
begin
FreeMem(chBuf);
GetMem(chBuf, DesBufSize);
BufSize:=DesBufSize;
end;
Res:=ReadFile(FChildStdoutRd, chBuf^, BufSize, dwRead, Nil);
Result:=Result+ChBuf;
end;
Until not Res;
Except
Result:='Read Err';
End;
end;
function DosToWin(St: string): string;
var
Ch: PChar;
begin
Ch := StrAlloc(Length(St) + 1);
OemToAnsi(PChar(St), Ch);
Result := Ch;
StrDispose(Ch)
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
if not WriteToChild(Edit1.Text) then ShowMessage('error');
Memo1.Lines.Add(DosToWin(ReadStrFromChild(100)));
end;


procedure TForm1.Button2Click(Sender: TObject);
begin
Memo1.Lines.Add(DosToWin(ReadStrFromChild(100)));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
NewPipe;
Memo1.Lines.Add(DosToWin(ReadStrFromChild(100)));
end;
[/more]
в едите посылал разные команды типа cd\ И подобных, все работало норм.
Автор: Phoenix555
Дата сообщения: 21.06.2006 13:34
не походящий вариант .. ВСЯ программа будет жать завершения функции ReadStrFromChild
почему я это пишу . .потомучто сделал чтобы всё было ок в моем коде .. собственно вот:
MooniePas.pas
[more]

Код:
unit MooniePas;

interface

uses
Windows, Classes,Forms,sysutils, ExtCtrls, ScktComp,
Sockets, Controls, StdCtrls,dialogs,th;

type
SECURITY_ATTRIBUTES = record
nLength: DWORD;
lpSecurityDescriptor: POINTER ;
end;
TForm1 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Button3: TButton;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure cmd;
//------------------------------------
private
{ Private declarations }
public
{ Public declarations }
si: STARTUPINFO;
sa: PSecurityAttributes;
sd: SECURITY_DESCRIPTOR;
pi: PROCESS_INFORMATION;
outRead,inRead,outWrite,inWrite: tHANDLE;
buf: array [0..1024] of char;
end;
var
Form1: TForm1;
thrc:thr;
a:pchar;
implementation

{$R *.dfm}
//------------------------------------------------------------------------------
function WinToDos(St: string): string;
var
Ch: PChar;
begin
Ch := StrAlloc(Length(St) + 1);
AnsiToOem(PChar(St), Ch);
Result := Ch;
StrDispose(Ch)
end;
//------------------------------------------------------------------------------
procedure tform1.cmd;
var
DesBufSize: DWORD;
exit:dword;
begin
InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);// после добавления этих строк
SetSecurityDescriptorDacl(@sd, true, nil, false);//всё стало работать нормально
new(sa);
sa.nLength := sizeof(PSECURITYATTRIBUTES);
sa.bInheritHandle := true;
sa.lpSecurityDescriptor := nil;
CreatePipe (outRead, outWrite, sa, 0);
CreatePipe (inRead, inWrite, sa, 0);
SetHandleInformation(outRead, HANDLE_FLAG_INHERIT, 0);
SetHandleInformation(inWrite, HANDLE_FLAG_INHERIT, 0);
GetStartupInfo(si);
si.cb := sizeof(STARTUPINFO);
si.hStdError := outWrite;
si.hStdOutput := outWrite;
si.hStdInput := inRead;
si.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
si.wShowWindow := 0;
if CreateProcess('C:\WINDOWS\system32\cmd.exe',NIL,nil,nil,TRUE,CREATE_NEW_CONSOLE,NiL,NiL,si,pi)=true then
begin
thrc:=thr.Create(true);
thrc.Suspended:=false;
end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
i, DesBufSize: DWORD;
s:string;
begin
s:=wintodos(edit1.Text);
new(a);
a:=pchar(s+#13#10);
DesBufSize:=length(a);
if WriteFile( inWrite, a^, length(a), DesBufSize, nil )<>true then
showmessage(inttostr(getlasterror));
end;
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
cmd;
end;

end.
Автор: vserd
Дата сообщения: 21.06.2006 17:25
Phoenix555
Воспользуйся обратным вызовом (callBack).
посмотри на код ниже (OnGetText ).
Работает только в режиме считывания, но тебя то интересует как передать инфу после считывания в основную программу. Здесь реализовано построчное считывание из DOS программы.

[more]
unit RCOM_Wrapper;
{$ifopt D+}
{$Define Test}
{$Else}
{$undef Test}
{$Endif}

{$undef Test}

interface
uses Windows, Sysutils, Classes, extctrls, U_COM_PORT;
Const CRCOM_BufferSize = 82;
Type
TRCOM_GETText = procedure (Text : String; IsNewLine:Boolean = False; isError : Boolean = False ) of object;
TRCOM_BreakFunc = Function : boolean of object;
TRCOM_COM_Ports = 1..4;

TRCOM_Redirector = class(TObject)
private
FBatchFileName: String;
FBuffer: array[0..CRCOM_BufferSize] of Char;
FConnectTimeOut : Integer; {Время для установки соединения, в милисекундах}
FCOMPortSpeed: TCOMPortSpeed;
FCOMPortNum: TRCOM_COM_Ports;
FCMD_STR : String;
FFilesCopied : Word;
FEnviropmentVars : Tstringlist;
FEnviropmentBuffer : Pchar;
FExecuteResult : byte;
FOnGetText: TRCOM_GETText;
FOnlyFullLineText: Boolean;
FOnUserBreak: TRCOM_BreakFunc;
FOutStr : String;
FRCOM_Not_Found: Boolean;
FRCOM_NOT_Found_Count : Byte;
FRcomPath: String;
FSearchBathPath: String;
FStdInPipeRead ,FStdInPipeWrite : THandle;
FStdOutPipeRead, FStdOutPipeWrite : THandle;
FTimer : TTimer;
function Build_RCOM_CMD_SWITCH: String;
procedure CreateRedirPipes;
procedure CloseRedirHandle(Var PipeHandle : THandle);
PROCEDURE FinishRcom;
function GetIsBreak: Boolean;
function GetisExecuting: Boolean;
function RedirectChar : boolean;
Function RunRcom : Boolean;
procedure ProcessFilesCopiedString(ALine : String);
Procedure TerminateRCOM;
procedure BuildRcomEnviropmentBlock;
procedure TimerEvent(Sender: TObject);
procedure setConnectTimeOut(const Value: integer);
procedure SendCommandToRcom(Command: String);
protected
FRCOM_ProcessInfo: TProcessInformation;
procedure ErrorMessage(AText : String; IsNewLine:Boolean = False);
procedure TextMessage(AText : String; IsNewLine:Boolean = False);
procedure SetSearchBathPath(Value: String);
procedure SetBatchFileName(Value: String);
protected
property isExecuting : Boolean read GetisExecuting ;
public
constructor Create;
Destructor Destroy; override;
function Execute : Byte;
{$ifDef Test}
procedure SendCtrlC;
{$endif}
public
Property COMPortNum : TRCOM_COM_Ports read FCOMPortNum Write FCOMPortNum;
Property COMPortSpeed : TCOMPortSpeed read FCOMPortSpeed Write FCOMPortSpeed ;
Property EnviropmentVars : TStringList read FEnviropmentVars ;
property FilesCopied : Word Read FFilesCopied;
property IsBreak : Boolean read GetIsBreak;
property BatchFileName : String read FBatchFileName write SetBatchFileName;
property OnGetText : TRCOM_GETText read FOnGetText write FOnGetText;
Property OnlyFullLineText : Boolean read FOnlyFullLineText Write FOnlyFullLineText ;
property OnUserBreak : TRCOM_BreakFunc Read FOnUserBreak write FOnUserBreak;
property RcomPath : String read FRcomPath write FRcomPath;
property SearchBathPath : String read FSearchBathPath write SetSearchBathPath;
Property Timeout : integer read FConnectTimeOut Write setConnectTimeOut ;
end;

ERCOM_Error = class(Exception);
ERCOM_Cannot_Execute = class(ERCOM_Error);
ERCOM_InvalidPathToRCOM = class(ERCOM_Error);
ERCOM_COMPortIsBusy = class(ERCOM_Error);
// ERCOM_InvalidBathName = class(ERCOM_Error);
const
C_RCOM_ExecuteResult = 0;
C_RCOM_ExecuteResult_Success = C_RCOM_ExecuteResult + 0; {Успешное окончание}
C_RCOM_ExecuteResult_TimeOut = C_RCOM_ExecuteResult + 1; {Истекло время ожидания}
C_RCOM_ExecuteResult_UserAbort = C_RCOM_ExecuteResult + 2; {Прервано пользователем}
C_RCOM_ExecuteResult_RCOM_NOT_RUN = C_RCOM_ExecuteResult + 3; {не удалось запустить RCOM}
C_RCOM_ExecuteResult_COMPortIsBusy= C_RCOM_ExecuteResult + 4; {COM-порт занят другой программой}
implementation
uses Forms, controls, process, PJEnvVars, uPushKeys;
const
C_CMD_Swith = '%0:S %1:S %2:S';
C_CMD_Str_Win32_NT = '%comspec% /c '+ C_CMD_Swith;
C_CMD_Str_Win32_9x = '%comspec% /c' + C_CMD_Swith;
C_DEfault_connect_Timeout = 1 * 60 * 1000; {одна минута}
C_RCOM_NOT_Found_MAX_Count = 3;{Кол-во попыток запустить RCOM}
{******************************************************************************}
{ TRCOM_Wrapper }
{******************************************************************************}
function TRCOM_Redirector.Build_RCOM_CMD_SWITCH: String;
begin
Result := '';
Result := Result + '/C ' ; {Автоматический выход}
Result := Result + ' /PCOM'+ IntToStr(COMPortNum); {номер Com-порта по которому будем устанавливать связь}
Result := Result + ' /B'+ IntToStr(ComPortSpeedToNum(COMPortSpeed)) ; {Скорость порта}
if (SearchBathPath <> '') and (Pos('~',SearchBathPath) = 0)
then Result := Result + ' /Y'+SearchBathPath; {Путь для поиска командных файлов}
end;
{******************************************************************************}
procedure TRCOM_Redirector.CloseRedirHandle(var PipeHandle: THandle);
begin
if PipeHandle <> INVALID_HANDLE_VALUE then begin
FlushFileBuffers(PipeHandle);
CloseHandle(PipeHandle);
PipeHandle := INVALID_HANDLE_VALUE;
end;
end;
{******************************************************************************}
constructor TRCOM_Redirector.Create;
begin
inherited Create;
FOnlyFullLineText := true;
FStdInPipeRead := INVALID_HANDLE_VALUE;
FStdInPipeWrite := INVALID_HANDLE_VALUE;
FStdOutPipeWrite := INVALID_HANDLE_VALUE;
FStdOutPipeRead := INVALID_HANDLE_VALUE;
if (Win32Platform = VER_PLATFORM_WIN32_NT)
then FCMD_Str := C_CMD_Str_WIN32_NT
Else FCMD_Str := C_CMD_Str_WIN32_9x;
FCMD_Str:= ExpandEnvVars(FCMD_Str);
FEnviropmentVars := Tstringlist.Create;
GetAllEnvVars(FEnviropmentVars);
FEnviropmentBuffer := nil;
FConnectTimeOut := C_DEfault_connect_Timeout; {по умолчанию, задержка 1 минута}
FTimer := TTimer.Create(nil);
with FTimer do begin
Enabled := False;
Interval := FConnectTimeOut;
OnTimer := TimerEvent;
end;
FCOMPortNum := 1;
FCOMPortSpeed := ps19200;
FRCOM_NOT_Found_Count := 0;
end;
{******************************************************************************}
procedure TRCOM_Redirector.CreateRedirPipes;
var
SA: TSecurityAttributes;
tmp1 : THandle;
begin
{Устанавливаем атрибуты безопастности}
with SA do
begin
nLength := SizeOf(SA);
bInheritHandle := True;
lpSecurityDescriptor := nil;
end;
{Создаем канал, для получения данных из StdOut}
if not CreatePipe(tmp1, // read handle
FStdOutPipeWrite, // write handle
@SA, // security attributes
0 // number of bytes reserved for pipe - 0 default
) then RaiseLastWin32Error;
//Делаем НЕ наследуемый дубликат "Читального" (Read) конца Pipe'a.
// if not SetStdHandle(STD_OUTPUT_HANDLE, FStdOutPipeWrite) then RaiseLastWin32Error;
If not DuplicateHandle(GetCurrentProcess(), Tmp1, GetCurrentProcess(), @FStdOutPipeRead, 0, False, DUPLICATE_SAME_ACCESS)
Then begin
CloseRedirHandle(FStdOutPipeRead);
CloseRedirHandle(FStdOutPipeWrite);
RaiseLastWin32Error;
end;
CloseHandle(Tmp1);//Закроем наследуемый вариант "Читального" хэндла
{Создаем канал для записи данных в StdIn}
if not CreatePipe(FStdInPipeRead, Tmp1, @SA,0) then begin
CloseRedirHandle(FStdOutPipeRead);
CloseRedirHandle(FStdOutPipeWrite);
RaiseLastWin32Error;
end;
{Делаем не наследуемый дубликат хендла}
If not DuplicateHandle(GetCurrentProcess(), Tmp1, GetCurrentProcess(), @FStdInPipeWrite, 0, False, DUPLICATE_SAME_ACCESS)
Then begin
CloseRedirHandle(FStdOutPipeRead);
CloseRedirHandle(FStdOutPipeWrite);
CloseRedirHandle(FStdInPipeRead);
CloseRedirHandle(FStdInPipeWrite);
RaiseLastWin32Error;
end;
CloseHandle(Tmp1);//Закроем наследуемый вариант "Читального" хэндла
end;
{******************************************************************************}
destructor TRCOM_Redirector.Destroy;
begin
FTimer.Enabled := False;
FTimer.Free;
FEnviropmentVars.Free;
StrDispose(FEnviropmentBuffer);
CloseRedirHandle(FStdInPipeRead);
CloseRedirHandle(FStdInPipeWRite);
CloseRedirHandle(FStdOutPipeRead);
CloseRedirHandle(FStdOutPipeWrite);
inherited;
end;
{******************************************************************************}
function TRCOM_Redirector.Execute : Byte;
var
IsOK : Boolean;
tmpExitCode : DWORD;
begin
FExecuteResult := C_RCOM_ExecuteResult_Success; {Успешное окончание}
try
{$ifdef debug}
TextMessage('Start Execute: '+ DateTimeToStr(Now), true);
{$endif}
FRCOM_Not_Found := False;
FTimer.Enabled := false;
TEXTMESSAGE('', True);
FFilesCopied := 0;
if not ComPortIsFree('COM'+ IntToStr(COMPortNum)) then
begin
FExecuteResult := C_RCOM_ExecuteResult_COMPortIsBusy;
Exit;
end;

ZeroMemory(@FBuffer, Sizeof(FBuffer));
ZeroMemory(@FRCOM_ProcessInfo, Sizeof(FRCOM_ProcessInfo));
if isBreak then begin {userAbort;} exit; end;
FStdInPipeRead := INVALID_HANDLE_VALUE;
FStdInPipeWrite := INVALID_HANDLE_VALUE;
FStdOutPipeWrite := INVALID_HANDLE_VALUE;
FStdOutPipeRead := INVALID_HANDLE_VALUE;
CreateRedirPipes;
try
{$ifdef debug} TextMessage('Start RCOM: '+ DateTimeToStr(Now), True); {$endif}
if RunRcom then begin
{$ifdef debug} TextMessage('Running RCOM: '+ DateTimeToStr(Now), True); {$endif}
FOutStr := '';
try
Screen.Cursor := crHourglass;
repeat
IsOK := RedirectChar;
Application.ProcessMessages;
{Вставить обработку прерывания от пользователя}
if IsBreak then begin
TerminateRCOM;
Break;
end;{if}
until (not IsOK) or (not isExecuting);
IsOk := True;
while IsOK do begin
isOk := isOk and isExecuting;
RedirectChar;
if Isbreak then Exit;
Application.ProcessMessages;
end; {while}
except
Raise;
end; {try except}
end

{$ifdef debug} else TextMessage('Failure RCOM: '+ DateTimeToStr(Now), True); {$endif}
{$ifdef debug} TextMessage('Finish RCOM: '+ DateTimeToStr(Now), True); {$endif}
finally
GetExitCodeProcess(FRCOM_ProcessInfo.hProcess, tmpExitCode);
FRCOM_NOT_Found := tmpExitCode <> 0;
SendCommandToRcom('Quit~ Exit~');
Screen.Cursor := crDefault;
FinishRcom;
StrDispose(FEnviropmentBuffer);
FEnviropmentBuffer := nil;
FTimer.Enabled := False;
CloseRedirHandle(FStdInPipeRead);
CloseRedirHandle(FStdInPipeWRite);
CloseRedirHandle(FStdOutPipeRead);
CloseRedirHandle(FStdOutPipeWrite);
end;

if not FRCOM_NOT_Found
then FRCOM_NOT_Found_Count := 0
else begin {Если не удалось запустить Rcom, пробуем еще раз}
if FRCOM_NOT_Found_Count > C_RCOM_NOT_Found_MAX_Count
then begin
FRCOM_NOT_Found_Count :=0;
Exit;
end {then}
else begin
inc(FRCOM_NOT_Found_Count);
Execute;
end; {else}
end;
if FRCOM_NOT_Found then FExecuteResult := C_RCOM_ExecuteResult_RCOM_NOT_RUN;
{$ifdef debug} TextMessage('Finish Execute: '+ DateTimeToStr(Now), True); {$endif}
finally
Result := FExecuteResult;
end;
end;
{******************************************************************************}
procedure TRCOM_Redirector.FinishRcom;
begin
try
if isExecuting then TerminateRCOM;
finally
RedirectChar;
Application.ProcessMessages;
CloseRedirHandle(FRCOM_ProcessInfo.hThread);
CloseRedirHandle(FRCOM_ProcessInfo.hProcess);
CloseRedirHandle(FStdInPipeWRite);
CloseRedirHandle(FStdOutPipeRead);
SendCommandToRcom('^C Y~ Quit~ Exit~');
SendCommandToRcom('Quit~ Exit~');
if Isbreak then TextMessage('Работа прервана пользователем', True);
end;
end;
{******************************************************************************}
function TRCOM_Redirector.GetIsBreak: Boolean;
begin
Result := False;
If Assigned(FOnUserBreak) then Result := FOnUserBreak;
if Result then FExecuteResult := C_RCOM_ExecuteResult_UserAbort;
end;
{******************************************************************************}
function TRCOM_Redirector.GetisExecuting: Boolean;
var tmpExitCode : DWORD;
begin
GetExitCodeProcess(FRCOM_ProcessInfo.hProcess, tmpExitCode);
Result := tmpExitCode = STILL_ACTIVE;
end;
{******************************************************************************}
function TRCOM_Redirector.RedirectChar: boolean;
var
BytesRead, writeBufferWritten, i: Cardinal;
tmpchar : Char;
begin
Result := False;
PeekNamedPipe(FStdOutPipeRead, nil, 0, nil, @writeBufferWritten, nil);
if writeBufferWritten = 0
then Result := False
else
for i:= 0 to writeBufferWritten-1 do
begin
Result := ReadFile(FStdOutPipeRead, tmpchar, 1, BytesRead, nil);
// has anything been read?
if BytesRead > 0 then begin
if tmpchar in [#08, #10] then Continue;
if Length(FOutStr) >=80 then begin
TextMessage(tmpchar);
tmpchar := #13;
end;
if tmpchar = #13 then begin
TextMessage(tmpchar, true);
FOutStr := FOutStr + tmpchar;
ProcessFilesCopiedString(FOutStr);
//SetRcomNotFound(FOutStr);
FOutStr := '';
Continue;
end;
TextMessage(tmpchar);
FOutStr := FOutStr + tmpchar;
Application.ProcessMessages;
end;
end; {for}
end;
{******************************************************************************}
function TRCOM_Redirector.RunRcom: Boolean;
var
SI: TStartupInfo;
WorkingDir : PChar;
RCOM_CMD_SWITCH: String;
creationFlag : Cardinal;
begin
Result := False;
// Make child process use StdOutPipeWrite as standard out, and make sure it does not show on screen.
FillChar(SI, SizeOf(SI), 0);
ZeroMemory(@FRCOM_ProcessInfo, Sizeof(FRCOM_ProcessInfo));
with SI do
begin
cb := SizeOf(SI);
dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
{$ifnDef Test}
wShowWindow := SW_HIDE;
{$else}
wShowWindow := SW_Show;
{$endif}
{$ifnDef Test}
hStdInput := FStdInPipeRead;
hStdOutput := FStdOutPipeWrite;
hStdError := FStdOutPipeWrite;
{$else}
hStdInput := FStdInPipeRead ;
hStdOutput := FStdOutPipeWrite;
hStdError := FStdOutPipeWrite;
{$endif}
end;
if Isbreak then begin {userAbort;} exit; end;
// launch RCOM
if SearchBathPath = ''
then WorkingDir := nil
else WorkingDir := Pchar(SearchBathPath);
BuildRcomEnviropmentBlock;
RCOM_CMD_SWITCH := Build_RCOM_CMD_SWITCH;
creationFlag := CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS {or CREATE_NEW_PROCESS_GROUP};
if (Win32Platform = VER_PLATFORM_WIN32_NT) then creationFlag := creationFlag or CREATE_SEPARATE_WOW_VDM;
if RcomPath = EmptyStr then raise ERCOM_InvalidPathToRCOM.Create('Путь к программе RCOM не может быть пустым');

{$ifDef Debug}
TextMessage(Format(FCMD_Str,[RComPath, RCOM_CMD_SWITCH, BatchFileName]), true);
TextMessage('', true);
{$endif}
Application.ProcessMessages;
Result := CreateProcess(nil, PChar(Format(FCMD_Str,[RComPath, RCOM_CMD_SWITCH, BatchFileName])),
nil, nil, True,
creationFlag , { creation flags }
FEnviropmentBuffer, //Enviropment
WorkingDir, //Current Dir
SI {StartupInfo}, FRCOM_ProcessInfo {process Information});
// Now that the handle has been inherited, close write to be safe.
// We don't want to read or write to it accidentally.
CloseRedirHandle(FStdOutPipeWrite);
CloseRedirHandle(FStdInPipeRead);
// Sleep(100);
Result := isExecuting;
if Result
then FTimer.Enabled := True
else begin
FExecuteResult := C_RCOM_ExecuteResult_RCOM_NOT_RUN;
RaiseLastWin32Error;
end;
end;
{******************************************************************************}
procedure TRCOM_Redirector.TerminateRCOM;
begin
While WaitForSingleObject(FRCOM_ProcessInfo.hProcess, 5000) = Wait_TimeOut do
SendCommandToRcom('^C Y~ Quit~ Exit~');
end;
{******************************************************************************}
procedure TRCOM_Redirector.TextMessage(AText: String; IsNewLine: Boolean);
begin
Application.ProcessMessages;
if Assigned(FOnGetText) then begin
if OnlyFullLineText
then begin
if IsNewLine and ((FOutStr <> '') or (AText <> '')) then FOnGetText(FOutStr + AText , true, False)
end
else FOnGetText(AText, IsNewLine, False);
end;
{После успешного старта выключаем}
if FTimer.Enabled and ((POS('LINK STARTED', UpperCase(FOutStr)) <>0 ) or
(POS('STOP COMPLETED', UpperCase(FOutStr)) <>0))
then FTimer.Enabled := False;
Application.ProcessMessages;
end;
{******************************************************************************}
procedure TRCOM_Redirector.ProcessFilesCopiedString(ALine : String);
var tmpIdx{,I} : Integer;
begin
tmpIdx:= Pos('FILE(S) COPIED', AnsiUpperCase(ALine));
if tmpIdx <> 0 then begin
Delete(ALine, tmpIdx, length(ALine)- tmpIdx);
ALine := Trim(ALine);
tmpIdx := LastDelimiter(' ', ALine);
if tmpIdx > 0 then Delete(ALine, 1, tmpIdx);
try
FFilesCopied := FFilesCopied + StrToInt(Aline);
except
Raise
end; {except}
end; {if}
end;
{******************************************************************************}
procedure TRCOM_Redirector.SetSearchBathPath(Value: String);
var buff : ARRAY [0..MAX_PATH] OF Char;
begin
GetShortPathName(Pchar(Value),buff,MAX_PATH);
FSearchBathPath := buff;
end;
{******************************************************************************}
procedure TRCOM_Redirector.BuildRcomEnviropmentBlock;
var
TmpStr : String;
BufSize : integer;
begin
tmpstr := trim(ExpandEnvVars(SearchBathPath+';%Path%'));
FEnviropmentVars.Values['Path']:= TmpStr ;
BufSize := CreateEnvBlock(FEnviropmentVars, false, nil, 0);
StrDispose(FEnviropmentBuffer);
FEnviropmentBuffer := StrAlloc(BufSize);
CreateEnvBlock(FEnviropmentVars, False, FEnviropmentBuffer, BufSize);
end;
{******************************************************************************}
procedure TRCOM_Redirector.SetBatchFileName(Value: String);
var buff : ARRAY [0..MAX_PATH] OF Char;
begin
ZeroMemory(@Buff, Sizeof(buff));
GetShortPathName(Pchar(Value),buff,MAX_PATH);
FBatchFileName := buff;
if FBatchFileName = EmptyStr then FBatchFileName := Value;
end;
{******************************************************************************}
procedure TRCOM_Redirector.TimerEvent(Sender: TObject);
const WaitChars : Array [0..3] of char = ('|','/','-','\');
var I: Byte;
begin
FTimer.Enabled := False;
for I:= Low(WaitChars) to High(WaitChars) do begin
if (Pos(WaitChars[i], FOutStr) =1) or (FOutStr = '') then begin
TerminateRCOM;
RedirectChar;
TextMessage(FOutStr, True);
FOutStr:= '';
FExecuteResult := C_RCOM_ExecuteResult_TimeOut;
ErrorMessage('Не удалось соединиться с терминалом. Истекло время подлючения (тайм аут)', True);
Exit;
end;
end; {For}
FTimer.Enabled := True;
end;
{******************************************************************************}
procedure TRCOM_Redirector.setConnectTimeOut(const Value: integer);
begin
FConnectTimeOut := Value;
FTimer.Interval:= Value;
end;
{******************************************************************************}
procedure TRCOM_Redirector.SendCommandToRcom(Command: String);
var pushkey : TPushKeys; hwdForeground : THandle;
begin
hwdForeground := GetForegroundWindow;
pushkey := TPushKeys.Create(nil);
try
pushkey.UseDirectTargetHandle := true;
pushkey.TargetHandle := FindMainWindowHandle(FRCOM_ProcessInfo.dwProcessId);
pushkey.TrackTarget := False;
//pushkey.ReturnFocus := True;
pushkey.Push(Command);
Application.ProcessMessages;
RedirectChar;
finally
Application.ProcessMessages;
pushkey.Free;
SetForegroundWindow(hwdForeground);
end;
end;
{******************************************************************************}
procedure TRCOM_Redirector.ErrorMessage(AText: String; IsNewLine: Boolean);
begin
if Assigned(FOnGetText) then FOnGetText(AText, IsNewLine, True);
end;
{******************************************************************************}
{$ifDef Test}
procedure TRCOM_Redirector.SendCtrlC;
var Result : Bool; Written : Cardinal;
begin
Result := WriteFile(FStdInPipeWrite, [#11,'C'],2, Written, 0);
if Result then TextMessage('Succes', True) else TextMessage('Failure', True);
end;
{$endif}
{******************************************************************************}
end.


............
Тестовые классы для проверки работы.


unit TST_RCOMWrapper;

interface
uses
Classes,
TestFramework, RCOM_Wrapper;
Type
TTEST_RCOM_Wrapper = class(TTestCase)
private
FWrapper : TRCOM_Redirector;
FBreakRcom : Boolean;
FLogFileName : String;
FLog : TStringList;
procedure CreateRCOMWrapper;
Function BreakRcom : boolean;
procedure UserBreakTimer(Sender: TObject);
procedure Logging(Text : String; IsNewLine:Boolean = False; isError : Boolean = False);
function RcomNotFoundRus(AFileName: String): Boolean;
// procedure Test_RCOMTimeOut;
public
procedure Setup; override;
procedure TearDown; override;
published
procedure Test_CreateWrapper;
procedure Test_RCOMTerminate;
Procedure Test_DoubleRun;
procedure Test_CopyFilesCount;
procedure Test_ExecuteResult ;

end;
implementation
uses windows, extctrls, sysutils, forms;
Type
TCRACK_RCOMRedirector = class(TRCOM_Redirector);
const
CRCOM_DIR = 'D:\Rcom\';
CRCOM_Path = CRCOM_DIR +'RCOM.EXE'; //test.bat
var
PathToBathFiles : String;

{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Setup;
begin
inherited;
FLog := TStringList.create;
FBreakRcom := False;
CreateRCOMWrapper;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.TearDown;
begin
if (FLog.Count <> 0) and (FLogFileName <> EmptyStr) then FLog.SaveToFile(FLogFileName);
FLog.Free;
FWrapper.Free;
FWrapper:= nil;
inherited;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Test_CreateWrapper;
begin
FWrapper.Free;
FWrapper:= TRCOM_Redirector.Create;
try
Check(Assigned(FWrapper), 'Не удалось создать объект');
finally
FWrapper.free;
FWrapper := nil;
end;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Test_RCOMTerminate;
var Timer : Ttimer;
begin
Timer := Ttimer.Create(nil);
FLogFileName := ExtractFileDir(Application.ExeName)+ '\Test_RCOMTerminate.log';
with FWrapper do begin
OnUserBreak := BreakRcom;
RcomPath := CRCOM_Path;
SearchBathPath := PathToBathFiles;
BatchFileName := PathToBathFiles +'test.bat';
end;

try
Timer.Enabled := false;
Timer.OnTimer := UserBreakTimer;
Timer.Interval := 5000;
Timer.Enabled := True;
CheckEquals(C_RCOM_ExecuteResult_UserAbort, FWrapper.Execute, 'Неверное значение для результата выполнение');
Check(not TCRACK_RCOMRedirector(FWrapper).FRCOM_ProcessInfo.hProcess <> INVALID_HANDLE_VALUE {isExecuting}, 'Программа выполняется после ''завершения''');
FLog.SaveToFile(FLogFileName);
finally
timer.free;
end;
end;
{******************************************************************************}
Function TTEST_RCOM_Wrapper.BreakRcom : boolean;
begin
Result := FBreakRcom;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.UserBreakTimer(Sender: TObject);
begin
TTimer(Sender).Enabled := FaLSE;
FBreakRcom := true;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Test_CopyFilesCount;
{*******}
Function CalcFilesCount : integer;
var
SR : TSearchRec;
DError : Integer;
tmpPath : String;
begin
Result := 0;
tmpPath := ExtractFileDir(Application.ExeName)+ '\TestCopy\Destinat\';
DError:=FindFirst(tmpPath + '*.dbf', faAnyFile, SR);
while DError = 0 do
begin
inc(Result);
DError:=FindNext(SR);
end;
FindClose(SR);
DError:=FindFirst(tmpPath + '*.txt', faAnyFile, SR);
while DError = 0 do
begin
inc(Result);
DError:=FindNext(SR);
end;
FindClose(SR);
end;
{*******}
begin
FLogFileName := ExtractFileDir(Application.ExeName)+ '\Test_CopyFilesCount.log';
FWrapper.BatchFileName := 'tstcopy.bat';
CheckEquals(C_RCOM_ExecuteResult_Success, FWrapper.Execute,'Неверное значение');
CheckEquals(CalcFilesCount, FWrapper.FilesCopied, ' неверное число скопированных файлов');
FLog.SaveToFile(FLogFileName);
// Check(not RcomNotFoundRus(FLogFileName), 'Не удалось найти RCOM');
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Logging(Text : String; IsNewLine:Boolean = False; isError : Boolean = False);
begin
if IsNewLine then FLog.Add(Trim(Text))
else begin
FLog.strings[FLog.Count -1] := FLog.strings[FLog.Count -1]+ Text;
end;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Test_DoubleRun;
var Timer : Ttimer; tmpResult : Byte;
begin
FLogFileName := ExtractFileDir(Application.ExeName)+ '\Test_DoubleRun.log';
with FWrapper do begin
OnUserBreak := BreakRcom;
SearchBathPath := PathToBathFiles;
BatchFileName := PathToBathFiles +'test.bat';
end;
FLog.Add(DateTimeTostr(Now));
tmpResult := FWrapper.Execute;
Check((tmpResult = C_RCOM_ExecuteResult_Success) or (tmpResult = C_RCOM_ExecuteResult_TimeOut), 'Неверное значение функции Execute');
FLog.Add(DateTimeTostr(Now));
FLog.SaveToFile(FLogFileName+'1');
{_$define Test_ReCreate}
{$ifdef Test_ReCreate}
FWrapper.Free;
FWrapper := nil;
CreateRCOMWrapper;
{ FWrapper := TRCOM_Redirector.create;}
with FWrapper do begin
OnUserBreak := BreakRcom;
SearchBathPath := PathToBathFiles;
BatchFileName := PathToBathFiles +'test.bat';
end;
{$endif}
FLog.SaveToFile(FLogFileName);
Check(not RcomNotFoundRus(FLogFileName), 'Не удалось найти RCOM');

FLog.Add('Second Execute');
//Sleep(100 *1000); {200 -работает 100 нет}

FBreakRcom := False;
Timer := Ttimer.Create(nil);
try
Timer.Enabled := false;
Timer.OnTimer := UserBreakTimer;
Timer.Interval := 700000;
Timer.Enabled := True;
tmpResult := FWrapper.Execute;
Check((tmpResult = C_RCOM_ExecuteResult_Success) or (tmpResult = C_RCOM_ExecuteResult_TimeOut), 'Неверное значение функции Execute 2');
finally
timer.Enabled := false;
timer.free;
end;
FLog.Add(DateTimeTostr(Now));
check(not FBreakRcom, 'Не удалось второй раз завершить процесс копирования. Выход по принудительному завершению.');
FLog.SaveToFile(FLogFileName);
Check( not RcomNotFoundRus(FLogFileName), 'Не удалось найти RCOM 2');
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.CreateRCOMWrapper;
begin
FWrapper := TRCOM_Redirector.create;
with FWrapper do begin
RcomPath := CRCOM_Path;
SearchBathPath := PathToBathFiles;
OnGetText := Logging;
end;
end;
{******************************************************************************}
function TTEST_RCOM_Wrapper.RcomNotFoundRus(AFileName: String): Boolean;
//const
var tmpList: TStringList;
begin
Result := False;
tmpList:= TStringList.Create;
try
tmpList.LoadFromFile(AFileName);
if Pos('ЌҐ г¤ Ґвбп - ©вЁ д ©«', tmpList.Text) >0 then Result := True;
finally
tmpList.Free;
end;
end;
{******************************************************************************}
procedure TTEST_RCOM_Wrapper.Test_ExecuteResult;
var tmpHndl : THandle;
begin
FLogFileName := ExtractFileDir(Application.ExeName)+ '\Test_ExecuteResult.log';
FWrapper.BatchFileName := 'tstcopy.bat';
FWrapper.RcomPath := 'D:\';
CheckEquals(C_RCOM_ExecuteResult_RCOM_NOT_RUN, FWrapper.Execute,'Неверное значение');
FWrapper.BatchFileName :='';
CheckEquals(C_RCOM_ExecuteResult_RCOM_NOT_RUN, FWrapper.Execute,'Неверное значение 2');
tmpHndl := CreateFile(Pchar('\\.\COM'+ IntToStr(FWrapper.COMPortNum)), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0,0);
try
CheckEquals(C_RCOM_ExecuteResult_COMPortIsBusy, FWrapper.Execute,'Неверное значение 3');
finally
CloseHandle(tmpHndl);
end;

// FLog.SaveToFile(FLogFileName);
end;
{******************************************************************************}
initialization
TestFramework.RegisterTest('RCOM.Wrapper', TTEST_RCOM_Wrapper.suite);
PathToBathFiles := IncludeTrailingBackslash(ExtractFilePath(Application.ExeName))+ 'Utils\Batch\';
end.

[/more]
И пользуйся тегом more
Автор: ShIvADeSt
Дата сообщения: 22.06.2006 01:09
Phoenix555
У тебя были траблы с записью в консоль, я дал тебе код в котором работает и запись и чтение, просто меня ломало искать ошибку в твоем, поэтому дал аналогичный, но который и пишет и читает.
Автор: Phoenix555
Дата сообщения: 11.07.2006 18:15
Мне не нужны решения, которые я не ищу! такие примеры я видел в сети .. вывод результат в файл, в TMemo и тд, но эти решения, включая твоё, в данной ситуации, не могут быть верным в принципе! Потомучто результат выодится только после завершения работы дочернего процесса, а у меня он работает и параллельно получается результат! И с вводом теперь всё в порядке.

Но есть проблемы с использованием консольного фтп-клиента .. т.е большая часть вывода просто не показывается ...

прошу кому не лень глянуть в исходник

http://mkirc.cabspace.com/tmp/_Moonie.zip

а кого ломает, хотябы не оффтопьте

Страницы: 1

Предыдущая тема: Казахский шрифт в Delphi 7


Форум Ru-Board.club — поднят 15-09-2016 числа. Цель - сохранить наследие старого Ru-Board, истории становления российского интернета. Сделано для людей.