Read text from a dosshell

Windows 95/NT or Windows 3.x

Regards,

Erik.

Win 95 and Delphi 2.01

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.

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.

Thanks a lot.
Thanks for your extremly fast answars :)
I will download the source when you post it :) Thanks again.

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.

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.

Thanks a lot for excellent help :)

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