1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:

{  
TConsoleSession by maxk  

If think, all properties are known. So I needn't present it here.  
PLEASE NOTE: TConsoleSession isn't able to run 16-Bit applications  
under systems higher than Windows NT.  
If you have any questions and/or ideas please mail me: delphi_max@lycos.de  
}  


unit ConsoleSession;  


interface  


uses  
  Windows, Messages, SysUtils, Classes, ExtCtrls;  


type  
  TGotBytesEvent=procedure(Sender:TObject;Buffer:string) of object;  
  TConsoleSession = class(TComponent)  
   constructor Create(AOwner:TComponent); override;  
   destructor Destroy; override;  
   procedure Write(Buffer:string);  
   procedure WriteLn(Buffer:string);  
   function Running:boolean;  
   procedure ReadFromPipe;  
   procedure Execute;  
   procedure Terminate(ExitCode:Cardinal=0);  
   procedure WaitFor(TimeOut:Cardinal=0);  
   function GetProcess:Cardinal;  
  private  
    FCommandLine:string;  
    FReadBufferSize:Cardinal;  
    FWriteBufferSize:Cardinal;  
    FReadInterval:integer;  
    FOnGotBytes:TGotBytesEvent;  
    Timer:TTimer;  
    hIReadPipe,hIWritePipe,hOReadPipe,hOWritePipe:THandle;  
    ProcessInfo:TProcessInformation;  
    procedure FReadFromPipe(Sender:TObject);  
    procedure SetReadInterval(NewInterval:integer);  
    procedure CleanUp;  
  protected  
    { Protected-Deklarationen }  
  public  
    { Public-Deklarationen }  
  published  
    property CommandLine:string read FCommandLine write FCommandLine;  
    property ReadBufferSize:Cardinal read FReadBufferSize write FReadBufferSize;  
    property WriteBufferSize:Cardinal read FWriteBufferSize  
     write FWriteBufferSize;  
    property ReadInterval:integer read FReadInterval write SetReadInterval;  
    property OnGotBytes:TGotBytesEvent read FOnGotBytes write FOnGotBytes;  
  end;  


procedure Register;  


implementation  


constructor TConsoleSession.Create(AOwner:TComponent);  
begin  
 inherited Create(AOwner);  


 if csDesigning   in ComponentState then begin  
  MessageBox(0,'Please note that TConsoleSession isn''t able to run 16-Bit '+  
   'applications under systems higher than Windows NT.'+#13+'When you have any'+  
   ' ideas so mail me: delphi_max@lycos.de - Thanks'+#13+'This message only '+  
   'appears in design time.','Warning',MB_ICONEXCLAMATION);  
 end;  


 FCommandLine:='cmd.exe';  
 FReadBufferSize:=256;  
 FWriteBufferSize:=65535;  
 Timer:=TTimer.Create(nil);  
 Timer.OnTimer:=FReadFromPipe;  
 SetReadInterval(100);  
end;  


destructor TConsoleSession.Destroy;  
begin  
 Timer.Free;  
 if Running then TerminateProcess(ProcessInfo.hProcess,0);  
 CleanUp;  
 inherited Destroy;  
end;  


procedure TConsoleSession.Write(Buffer:string);  
var BytesToWrite,BytesWritten:Cardinal;  
begin  
 if not Running then  
  raise Exception.Create(Name+': Command not running');  
 while length(Buffer)>0 do begin  
  BytesToWrite:=length(Buffer);  
  if BytesToWrite>FWriteBufferSize then BytesToWrite:=FWriteBufferSize;  
  WriteFile(hIWritePipe,Buffer[1],BytesToWrite,BytesWritten,nil);  
  Delete(Buffer,1,BytesWritten);  
 end;  
end;  


procedure TConsoleSession.WriteLn(Buffer:string);  
begin  
 Write(Buffer+#13#10);  
end;  


function TConsoleSession.Running:boolean;  
begin  
 Result:=WaitForSingleObject(ProcessInfo.hProcess,0)=WAIT_TIMEOUT;  
end;  


procedure TConsoleSession.ReadFromPipe;  
begin  
 if not Running then  
  raise Exception.Create(Name+': Command not running');  
 FReadFromPipe(nil);  
end;  


procedure TConsoleSession.Execute;  
var SecAttr:TSecurityAttributes;  
    StartupInfo:TStartUpInfo;  
begin  
 if not Running then CleanUp else  
  raise Exception.Create(Name+': Already running');  


 with SecAttr do begin  
  nLength:=SizeOf(TSecurityAttributes);  
  bInheritHandle:=true;  
  lpSecurityDescriptor:=nil;  
 end;  


 if not CreatePipe(hIReadPipe,hIWritePipe,@SecAttr,0) then  
  raise Exception.Create(Name+': Unable to create write pipe');  
 if not Createpipe(hOReadPipe,hOWritePipe,@SecAttr,0) then  
  raise Exception.Create(Name+': Unable to create read pipe');  


 FillChar(StartupInfo,Sizeof(StartupInfo),#0);  
 with StartupInfo do begin  
  cb:=SizeOf(StartupInfo);  
  hStdOutput:=hOWritePipe;  
  hStdInput:=hIReadPipe;  
  dwFlags:=STARTF_USESTDHANDLES+STARTF_USESHOWWINDOW;  
  wShowWindow:=SW_HIDE;  
 end;  


 if not CreateProcess(nil,PChar(FCommandLine),@SecAttr,@SecAttr,True,  
  NORMAL_PRIORITY_CLASS,nil,nil,StartupInfo,ProcessInfo) then  
   raise Exception.Create(Name+': Unable to start command.'+#13+'Error: '+  
   IntToStr(GetLastError));  
end;  


procedure TConsoleSession.Terminate(ExitCode:Cardinal=0);  
begin  
 if not Running then  
  raise Exception.Create(Name+': Command not running');  
 TerminateProcess(ProcessInfo.hProcess,ExitCode);  
 CleanUp;  
end;  


procedure TConsoleSession.WaitFor(TimeOut:Cardinal=0);  
var Tick:Cardinal;  
begin  
 Tick:=GetTickCount;  
 while (Tick+TimeOut>GetTickCount) and (Running) and (TimeOut=0) do begin  
  Sleep(1);  
 end;  
end;  


function TConsoleSession.GetProcess:Cardinal;  
begin  
 if not Running then  
  raise Exception.Create(Name+': Command not running');  
 Result:=ProcessInfo.hProcess;  
end;  


procedure TConsoleSession.FReadFromPipe(Sender:TObject);  


 function BytesInPipe:Cardinal;  
 begin  
  if not PeekNamedPipe(hOReadPipe,nil,0,nil,@Result,nil) then Result:=0;  
 end;  


var BytesRead:DWord;  
    Buffer:string;  
begin  
 if (not Running) or (BytesInPipe=0) then exit;  
 try  
  Timer.Enabled:=False;  
  repeat  
   BytesRead:=0;  
   SetLength(Buffer,FReadBufferSize);  
   ReadFile(hOReadPipe,Buffer[1],length(Buffer),BytesRead,nil);  
   SetLength(Buffer,BytesRead); // Remove trash from other reads  
   OemToAnsi(@Buffer[1],@Buffer[1]);  
   if Assigned(FOnGotBytes) then FOnGotBytes(Self,Buffer);  
  until BytesInPipe=0;  
 finally  
  Timer.Enabled:=True;  
 end;  
end;  


procedure TConsoleSession.SetReadInterval(NewInterval:integer);  
begin  
 Timer.Interval:=NewInterval;  
 FReadInterval:=Timer.Interval;  
end;  


procedure TConsoleSession.CleanUp;  
begin  
 if ProcessInfo.hProcess<>0 then CloseHandle(ProcessInfo.hProcess);  
 if ProcessInfo.hThread<>0 then CloseHandle(ProcessInfo.hThread);  
 if hOReadPipe<>0 then CloseHandle(hOReadPipe);  
 if hOWritePipe<>0 then CloseHandle(hOWritePipe);  
 if hIReadPipe<>0 then CloseHandle(hIReadPipe);  
 if hIWritePipe<>0 then CloseHandle(hIWritePipe);  


 ProcessInfo.hProcess:=0;  
 ProcessInfo.hThread:=0;  
 hOReadPipe:=0;  
 hOWritePipe:=0;  
 hIWritePipe:=0;  
 hOWritePipe:=0;  
end;  


procedure Register;  
begin  
  RegisterComponents('maxk', [TConsoleSession]);  
end;  


end.