Solved

Read text from a dosshell

Posted on 1997-05-18
9
260 Views
Last Modified: 2010-04-03
I wish to start a dosprogram in a dosshell, then I wish to read everything wich is display (Is it possible to read In21?)
I Also want to send keypress to the program.
Thanks !
0
Comment
Question by:chrb
  • 5
  • 4
9 Comments
 
LVL 3

Expert Comment

by:sperling
ID: 1336446
Windows 95/NT or Windows 3.x

Regards,

Erik.
0
 

Author Comment

by:chrb
ID: 1336447
Win 95 and Delphi 2.01
0
 
LVL 3

Accepted Solution

by:
sperling earned 150 total points
ID: 1336448
First, use CreatePipe to create a pipe for STDIN, STDOUT and STDERR.
Then, use DuplicateHandle to create copies of the pipe handles, and to set them inheritable.

E.g.
  CreatePipe (temp, hWriteSTDIN, nil, 1024);
  DuplicateHandle
    (GetCurrentProcess,
    temp,
    GetCurrentProcess,
    @hReadSTDIN,
    0,
    TRUE,
    DUPLICATE_SAME_ACCESS or DUPLICATE_CLOSE_SOURCE);

Use same procedure for STDOUT and STDERR, except you need to duplicate the Write handle for these pipes.

Then, assuming you've got a StartupInfo of type TStartupInfo:

  StartupInfo.hStdInput := hReadSTDIN;
  StartupInfo.hStdOutput := hWriteSTDOUT;
  StartupInfo.hStdError := hWriteSTDERR;
  StartupInfo.dwFlags := STARTF_USESTDHANDLES;

Next, start the exe using CreateProcess. Pass TRUE for the bInheritHandles parameter, and also pass the StartupInfo containing the handles.

Determine whether there are data to be read:

if PeekNamedPipe (hReadSTDOUT, nil, 0, nil, @BytesAvailable, nil)
then begin
  // 'BytesAvailable' bytes of data waiting.
  // Read it using ReadFile (hReadSTDOUT, ....
end;

Send data using WriteFile (hWriteSTDIN, ....

You need to check the hReadSTDOUT handle regularly, it might be better doing this in a thread.

I've used this method to execute a DOS session, having the output go to a listbox, and using an Edit to send data to the dos session.

If you wan't to hide the program also, set StartupInfo.wShowWindow to SW_HIDE, and add STARTF_USESHOWWINDOW to StartupInfo.dwFlags

If anything is unclear, please leave me a comment.


Regards,

Erik.

0
 

Author Comment

by:chrb
ID: 1336449
How do I define StartupInfo, I only got this message :
undeclerad identifier : 'startupinfo'

May I get the source to the program you had made? Wich executed a dossession an let i go into a listbox. Please.

Anyway thanks.
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 3

Expert Comment

by:sperling
ID: 1336450

StartupInfo : TStartupInfo;
ProcessInfo : TProcessInformation;

Both types declared in WIndows unit.


I can send you the source, but it won't work on 95, only on NT... I use the security features of NT to set the handles inheritable, whereas 95 needs to use DuplicateHandle because it doesn't support security.

Give me a few days or so and I'll have it work on 95 too, then I'll post it here.

Regards,

Erik.
0
 

Author Comment

by:chrb
ID: 1336451
Thanks a lot.
Thanks for your extremly fast answars :)
I will download the source when you post it :) Thanks again.
0
 
LVL 3

Expert Comment

by:sperling
ID: 1336452
Hmmm... Seems I had already implemented DuplicateHandle. Anyway, it works on 95, so here goes.

The unit "Redirect" contains a class/component which encapsulates a dos box. It's not commented, and I haven't finished testing it out, so there'll probably be errors.

The unit CATestMain is the unit for the test programs main form. Create a new blank project, and reconstruct the events/methods of this unit into your main forms code.

If you experiment a little, you'll see how it works. Feel free to use the Redirector class as you wish, but as said before, it most probably still contains errors.



-------------------------
unit Redirect;

interface

uses
  Windows, SysUtils, Classes;

type
  TRedirector = class;

  TPriorityClass = (pcDefault, pcIdle, pcNormal, pcHigh, pcRealtime);

  TDataEvent = procedure (Sender : TRedirector; buffer : POINTER; Size : INTEGER) of object;

  TRedirector = class {$IFDEF COMPONENT} (TComponent) {$ENDIF}
  private
    FAvailable        : INTEGER;
    procedure ReadStdOutput;
    procedure ReadStdError;
    procedure ProcessTerminated;
  protected
    FProcessInfo      : TProcessInformation;
    FExitCode         : INTEGER;
    FExecutable       : STRING;
    FParameters       : STRING;
    FDefaultErrorMode : BOOLEAN;
    FStartSuspended   : BOOLEAN;
    FKillOnDestroy    : BOOLEAN;
    FDirectory        : STRING;
    FEnvironment      : POINTER;
    FInitialPriority  : TPriorityClass;
    FPipeInput,
    FPipeOutput,
    FPipeError        :
      record
        hRead,
        hWrite        : DWORD;
      end;
    FThread           : TThread;
    FOnData,
    FOnErrorData      : TDataEvent;
    FOnTerminated     : TNotifyEvent;
    procedure Error (msg : STRING);
    procedure WinError (msg : STRING);
    procedure CreatePipes;
    procedure ClosePipes;

    function  GetRunning : BOOLEAN;
    function  GetExitCode : INTEGER;
    function  GetProcessID : INTEGER;
    function  GetThreadID : INTEGER;
    function  GetProcessHandle : INTEGER;
    function  GetThreadHandle : INTEGER;
    procedure SetExecutable (value : STRING);
    procedure SetParameters (value : STRING);
    function  GetCommandLine : STRING;
    procedure SetCommandLine (value : STRING);
    procedure SetDefaultErrorMode (value : BOOLEAN);
    procedure SetStartSuspended (value : BOOLEAN);
    procedure SetInitialPriority (value : TPriorityClass);
    procedure SetDirectory (value : STRING);
    procedure SetEnvironment (value : POINTER);
    property  ProcessHandle : INTEGER
      read GetProcessHandle;
    property  ThreadHandle : INTEGER
      read GetThreadHandle;
  public
    destructor Destroy; override;
    procedure Terminate (dwExitCode : INTEGER);
    procedure Start;
    procedure SendData (Buffer : POINTER; BufferSize : INTEGER);
    procedure SendText (s : STRING);
    property  Running : BOOLEAN
      read GetRunning;
    property  ExitCode : INTEGER
      read GetExitCode;
    property  ProcessID : INTEGER
      read GetProcessID;
    property  ThreadID : INTEGER
      read GetThreadID;
    property  Environment : POINTER
      read FEnvironment
      write SetEnvironment;
  published
    property  KillOnDestroy : BOOLEAN
      read FKillOnDestroy
      write FKillOnDestroy;
    property  Executable : STRING
      read FExecutable
      write SetExecutable;
    property  Parameters : STRING
      read FParameters
      write SetParameters;
    property  CommandLine : STRING
      read GetCommandLine
      write SetCommandLine;
    property  DefaultErrorMode : BOOLEAN
      read FDefaultErrorMode
      write SetDefaultErrorMode;
    property  StartSuspended : BOOLEAN
      read FStartSuspended
      write SetStartSuspended;
    property  InitialPriority : TPriorityClass
      read FInitialPriority
      write SetInitialPriority;
    property  Directory : STRING
      read FDirectory
      write SetDirectory;
    property OnData : TDataEvent
      read FOnData
      write FOnData;
    property OnErrorData : TDataEvent
      read FOnErrorData
      write FOnErrorData;
    property OnTerminated : TNotifyEvent
      read FOnTerminated
      write FOnTerminated;
  end;


implementation

const
  DUPLICATE_CLOSE_SOURCE = 1;
  DUPLICATE_SAME_ACCESS  = 2;

type
  TRedirectorThread = class (TThread)
  protected
    FRedirector     : TRedirector;
    procedure Execute; override;
    constructor Create(ARedirector : TRedirector);
  end;

////////////////////////////////////////////////////////////////////////////////
// Misc. internal methods
////////////////////////////////////////////////////////////////////////////////

procedure TRedirector.Error (msg : STRING);
begin
  raise Exception.Create(msg);
end;

procedure TRedirector.WinError (msg : STRING);
begin
  Error (msg + IntToStr(GetLastError));
end;


procedure TRedirector.CreatePipes;
var
  SecAttr : TSecurityAttributes;
begin
  SecAttr.nLength := SizeOf(SecAttr);
  SecAttr.lpSecurityDescriptor := nil;
  SecAttr.bInheritHandle := TRUE;

  with FPipeInput do begin
    if not CreatePipe (hRead, hWrite, @SecAttr, 1024)
      then WinError('Error on STDIN pipe creation : ');
    if not DuplicateHandle (GetCurrentProcess, hRead, GetCurrentProcess, @hRead, 0, TRUE, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS)
      then WinError('Error on STDIN pipe duplication : ');
  end;
  with FPipeOutput do begin
    if not CreatePipe (hRead, hWrite, @SecAttr, 1024)
      then WinError('Error on STDOUT pipe creation : ');
    if not DuplicateHandle (GetCurrentProcess, hWrite, GetCurrentProcess, @hWrite, 0, TRUE, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS)
      then WinError('Error on STDOUT pipe duplication : ');
  end;
  with FPipeError do begin
    if not CreatePipe (hRead, hWrite, @SecAttr, 1024)
      then WinError('Error on STDERR pipe creation : ');
    if not DuplicateHandle (GetCurrentProcess, hWrite, GetCurrentProcess, @hWrite, 0, TRUE, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS)
      then WinError('Error on STDERR pipe duplication : ');
  end;
end;

procedure TRedirector.ClosePipes;
begin
  with FPipeInput do begin
    if hRead <> 0 then CloseHandle (hRead);
    if hWrite <> 0 then CloseHandle (hWrite);
    hRead := 0;
    hWrite := 0;
  end;
  with FPipeOutput do begin
    if hRead <> 0 then CloseHandle (hRead);
    if hWrite <> 0 then CloseHandle (hWrite);
    hRead := 0;
    hWrite := 0;
  end;
  with FPipeError do begin
    if hRead <> 0 then CloseHandle (hRead);
    if hWrite <> 0 then CloseHandle (hWrite);
    hRead := 0;
    hWrite := 0;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
// Property implementations
////////////////////////////////////////////////////////////////////////////////
function  TRedirector.GetRunning : BOOLEAN;
begin
  Result := ProcessHandle<>0;
end;

function  TRedirector.GetExitCode : INTEGER;
begin
  if Running
    then Result := STILL_ACTIVE
    else Result := FExitCode;
end;

function  TRedirector.GetProcessID : INTEGER;
begin
  Result := FProcessInfo.dwProcessID;
end;

function  TRedirector.GetThreadID : INTEGER;
begin
  Result := FProcessInfo.dwThreadID;
end;

function  TRedirector.GetProcessHandle : INTEGER;
begin
  Result := FProcessInfo.hProcess;
end;

function  TRedirector.GetThreadHandle : INTEGER;
begin
  Result := FProcessInfo.hThread;
end;

procedure TRedirector.SetExecutable (value : STRING);
begin
  if (ANSICompareText(value, Executable) = 0) or not Running
    then FExecutable := value
  else if Running
    then Error('Cannot change Executable while process is active');
end;

procedure TRedirector.SetParameters (value : STRING);
begin
  if (ANSICompareText(value, Parameters) = 0) or not Running
    then FParameters := value
  else if Running
    then Error('Cannot change Parameters while process is active');
end;

function  TRedirector.GetCommandLine : STRING;
begin
  Result := FExecutable;
  if Result = ''
    then Result := FParameters
    else Result := FExecutable + ' ' + FParameters;
end;

procedure TRedirector.SetCommandLine (value : STRING);
var
  n1,
  n2      : INTEGER;
begin
  if (ANSICompareText (value, CommandLine) = 0) or (not Running) then begin
    n1 := Length(value);
    n2 := Pos(' ', value);
    if (n2>0) and (n2<n1) then n1 := n2;
    n2 := Pos('-', value);
    if (n2>0) and (n2<n1) then n1 := n2;
    n2 := Pos('/', value);
    if (n2>0) and (n2<n1) then n1 := n2;
    FExecutable := Copy (value, 1, n1-1);
    FParameters := Trim(Copy (value, Length(FExecutable)+1, Length(value)));
  end else if Running then Error('Cannot change CommandLine while process is active');
end;

procedure TRedirector.SetDefaultErrorMode (value : BOOLEAN);
begin
  if (value = DefaultErrorMode) or not Running
    then FDefaultErrorMode := value
  else if Running
    then Error('Cannot change DefaultErrorMode while process is active');
end;

procedure TRedirector.SetStartSuspended (value : BOOLEAN);
begin
  if (value = DefaultErrorMode) or not Running
    then FStartSuspended:= value
  else if Running
    then Error('Cannot change StartSuspended while process is active');
end;

procedure TRedirector.SetInitialPriority (value : TPriorityClass);
begin
  if (value = InitialPriority) or not Running
    then FInitialPriority := value
  else if Running
    then Error('Cannot change InititalPriority while process is active');
end;

procedure TRedirector.SetDirectory (value : STRING);
begin
  if (ANSICompareText (value, Directory) = 0) or (not Running)
    then FDirectory:= value
  else if Running
    then Error('Cannot change Directory while process is active');
end;

procedure TRedirector.SetEnvironment (value : POINTER);
begin
  if (value = Environment) or not Running
    then FEnvironment := value
  else if Running
    then Error('Cannot change Environment while process is active');
end;


procedure TRedirector.ReadStdOutput;
var
  BytesRead : INTEGER;
  buffer    : POINTER;
begin
  GetMem (buffer, FAvailable);
  try
    if not ReadFile (FPipeOutput.hRead, buffer^, FAvailable, BytesRead, nil) then begin
      FThread.Terminate;
      WinError('Error reading STDOUT pipe : ');
    end;
    if Assigned (FOnData) then begin
      FOnData(Self, buffer, BytesRead);      
    end;    
  finally
    FreeMem(buffer);
  end;
end;

procedure TRedirector.ReadStdError;
var
  BytesRead : INTEGER;
  buffer    : POINTER;
begin
  GetMem (buffer, FAvailable);
  try
    if not ReadFile (FPipeError.hRead, buffer^, FAvailable, BytesRead, nil) then begin
      FThread.Terminate;
      WinError('Error reading STDERR pipe : ');
    end;
    if Assigned (FOnErrorData) then begin
      FOnErrorData(Self, buffer, BytesRead);
    end;
  finally
    FreeMem(buffer);
  end;
end;

procedure TRedirector.ProcessTerminated;
begin
  FThread.Terminate;
  if Assigned (FOnTerminated) then FOnTerminated(Self);
  ClosePipes;
  CloseHandle(FProcessInfo.hProcess);
  CloseHandle(FProcessInfo.hThread);
  FillChar(FProcessInfo, SizeOf(FProcessInfo), 0);
end;

////////////////////////////////////////////////////////////////////////////////
// Public methods
////////////////////////////////////////////////////////////////////////////////
procedure TRedirector.Terminate (dwExitCode : INTEGER);
begin
  if Running
    then TerminateProcess(ProcessHandle, dwExitCode)
    else Error('Cannot Terminate an inactive process');
end;

procedure TRedirector.Start;
var
  StartupInfo   : TStartupInfo;
  szExecutable,
  szParameters,
  szDirectory   : PChar;
begin
  if Running then Error ('Process is already active');
  if Trim(CommandLine)='' then Error('No commandline to run');
  try
    CreatePipes;

    FillChar(StartupInfo, SizeOf(StartupInfo), 0);
    StartupInfo.cb := SizeOf(StartupInfo);

    StartupInfo.wShowWindow := SW_HIDE;
    StartupInfo.hStdInput := FPipeInput.hRead;
    StartupInfo.hStdOutput := FPipeOutput.hWrite;
    StartupInfo.hStdError := FPipeError.hWrite;
    StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

    if Trim(Executable) = ''
      then szExecutable := nil
      else szExecutable := PChar(FExecutable);
    if Trim(Parameters) = ''
      then szParameters := nil
      else szParameters := PChar(FParameters);
    if Trim(Directory)=''
      then szDirectory := nil
      else szDirectory := PChar(FDirectory);
    if CreateProcess (
      szExecutable,
      szParameters,
      nil,
      nil,
      TRUE,
      (CREATE_DEFAULT_ERROR_MODE and INTEGER(FDefaultErrorMode))
      or (CREATE_SUSPENDED and INTEGER(FStartSuspended)),
      Environment,
      szDirectory,
      StartupInfo,
      FProcessInfo)
    then begin
      FThread := TRedirectorThread.Create(Self);
    end else WinError('Error creating process : ');
  except
    on Exception do begin
      ClosePipes;
      CloseHandle(FProcessInfo.hProcess);
      CloseHandle(FProcessInfo.hThread);
      FillChar(FProcessInfo, SizeOf(FProcessInfo), 0);
      raise;
    end;
  end;
end;

procedure TRedirector.SendData (Buffer : POINTER; BufferSize : INTEGER);
var
  BytesWritten : INTEGER;
begin
  if not Running then Error ('Can''t send data to an inactive process');
  if not WriteFile (FPipeInput.hWrite, Buffer^, BufferSize, BytesWritten, nil)
    then WinError('Error writing to STDIN pipe : ');
end;

procedure TRedirector.SendText (s : STRING);
begin
  SendData(PChar(s), Length(s));
end;

destructor TRedirector.Destroy;
begin
  if Running and KillOnDestroy then begin
    FOnTerminated := nil;
    FThread.Terminate;
    Terminate(0);
  end;
  inherited Destroy;
end;

constructor TRedirectorThread.Create(ARedirector : TRedirector);
begin
  FRedirector := ARedirector;
  inherited Create(FALSE);
end;

procedure TRedirectorThread.Execute;
var
  Idle    : BOOLEAN;
begin
  FreeOnTerminate := TRUE;
  while not Terminated do begin
    Idle := TRUE;
    if PeekNamedPipe(FRedirector.FPipeOutput.hRead, nil, 0, nil, @FRedirector.FAvailable, nil) and (FRedirector.FAvailable>0) then begin
      Synchronize(FRedirector.ReadStdOutput);
      Idle := FALSE;
    end;
    if PeekNamedPipe(FRedirector.FPipeError.hRead, nil, 0, nil, @FRedirector.FAvailable, nil) and (FRedirector.FAvailable>0) then begin
      Synchronize(FRedirector.ReadStdError);
      Idle := FALSE;
    end;
    if Idle and (WaitForSingleObject(FRedirector.ProcessHandle, 100)=WAIT_OBJECT_0) then begin
      if not Terminated then Synchronize(FRedirector.ProcessTerminated);
    end;
  end;
end;

end.
-------------------------
unit CATestMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Redirect;

type
  TForm1 = class(TForm)
    LB: TListBox;
    Panel1: TPanel;
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
    procedure FormDestroy(Sender: TObject);
  private
    FRedirector        : TRedirector;
    procedure AddText (Text : STRING);
    procedure AppDone (Sender :TObject);
    procedure NewData (Sender : TRedirector; Buffer : POINTER; BufferSize : INTEGER);
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.NewData (Sender : TRedirector; Buffer : POINTER; BufferSize : INTEGER);
var
  temp    : PChar;
begin
  temp := StrAlloc(BufferSize+1);
  StrLCopy(temp, Buffer, BufferSize);
  temp[BufferSize] := #0;
  AddText(string(temp));
  StrDispose(temp);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FRedirector := TRedirector.Create;
  FRedirector.KillOnDestroy := TRUE;
  FRedirector.OnData := NewData;
  FRedirector.OnTerminated := AppDone;
end;

procedure TForm1.AddText (Text : STRING);
// Ugly.... Fix.
const
  IgnoreNewLine : BOOLEAN = FALSE;
var
  n,
  ndx           : INTEGER;
  s             : STRING;

  function FixTabs (s : STRING) : STRING;
  var
    n      : INTEGER;
  begin
    n := 1;
    while (n<=Length(s)) do begin
      if s[n] = #9 then begin
        while n MOD 8 <> 0 do begin
          Insert (' ', s, n);
          inc(n);
        end;
        s[n] := ' ';
      end;
      inc(n);
    end;
    Result := s;
  end;

begin
  if LB.Items.Count=0 then begin
    LB.Items.Add('');
    IgnoreNewLine := FALSE;
  end;
  ndx := 1;
  while ndx<=Length(text) do begin
    if text[ndx] in [#13, #10] then begin
      if IgnoreNewLine then begin
        IgnoreNewLine := FALSE;

      end else begin
        IgnoreNewLine := TRUE;
        LB.Items.Add('');
      end;
      inc (ndx);
      continue;
    end else begin
      s := LB.Items[LB.Items.Count-1];
      n := ndx-1;
      while (n < Length(text)) and not (text[n+1] in [#13, #10]) do inc(n);
      LB.Items [LB.Items.Count-1] := FixTabs(s + Copy(text, ndx, n-ndx+1));
      ndx := n;
    end;
    inc(ndx);
  end;
  LB.ItemIndex := LB.Items.Count-1;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Edit1.Width := Panel1.Width;
end;

procedure TForm1.AppDone (Sender :TObject);
begin
  Close;
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key=#13 then begin
    if FRedirector.Running then begin
      FRedirector.SendText(Edit1.Text+#13#10);
    end else begin
      FRedirector.CommandLine := Edit1.Text;
      FRedirector.Start;
    end;
    Edit1.Clear;
    Key := #0;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FRedirector.Free;
end;

end.
------------------


Leave me a comment if you get trouble.
0
 
LVL 3

Expert Comment

by:sperling
ID: 1336453
BTW.

Use the program by first typing complete path, filename and extension of command.com or the app you wan't to execute into the edit, and press enter. Then, type whatever like dir, attrib or something and press enter to send the data to the dos-box.

Don't try running e.g. dos edit, the redirector only handles standard line-by-line output programs. Arj, pkzip and so on works fine.

Regards,

Erik.
0
 

Author Comment

by:chrb
ID: 1336454
Thanks a lot for excellent help :)

To all : remember the "/c" parameter after command.com
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now