source: trunk/Library/RunProgramUnit.pas@ 154

Last change on this file since 154 was 154, checked in by RBRi, 18 years ago

warning fixes
  • Property svn:eol-style set to native
File size: 11.2 KB
RevLine 
[17]1unit RunProgramUnit;
2
3interface
4
5Uses
6{$ifdef os2}
7 OS2Def, BseDos, Dos, BseErr,
8{$endif}
9{$ifdef win32}
10 Windows,
11{$endif}
12 Forms,
13 ACLUtility;
14
15type
16{$ifdef os2}
17 TProgramHandle = ULONG;
18{$endif}
19{$ifdef win32}
20 APIRET = DWORD;
21 TProgramHandle = THandle;
22{$endif}
23
24// Runs a program in the given working directory.
25// If PrintOutput is assigned, StdOut (and StdErr) will be piped to it.
26
27// If CheckTerminateCallback is assigned, it will be called regularly and if the
28// process should be terminated, it should return true
29
30// Function returns 0 if the program was started OK.
31// Otherwise an OS error code.
32// ResultCode is set to 1 if the program did not start, otherwise
33// the exit code of the process
34Function RunProgram( ProgramName: string;
35 Parameters: string;
36 WorkingDir: string;
37 Var ResultCode: APIRET;
38 TerminateCheck: TTerminateCheck;
39 PrintOutput: TPrintOutput
40 ): APIRET;
41
42{$ifdef os2}
43// Lauches given program and immediately returns.
44// If successful in launching, returns 0 otherwise OS error code.
45// If successful, ProgramHandle can be used to operate on the program.
46Function LaunchProgram( ProgramName: string;
47 Parameters: string;
48 WorkingDir: string ): APIRET;
49{$endif}
50
51implementation
52
53Uses
54 SysUtils;
55
56{$ifdef os2}
57type
58 TermQResults=record
59 SessionID: WORD;
60 ResultCode: WORD;
61 end;
62{$endif}
63
64Function RunProgram( ProgramName: string;
65 Parameters: string;
66 WorkingDir: string;
67 Var ResultCode: APIRET;
68 TerminateCheck: TTerminateCheck;
69 PrintOutput: TPrintOutput
70 ): APIRET;
71{$ifdef win32}
72Const
73 PipeBufferSize = 10000;
74 PipeName = '\\.\pipe\myoutputpipe';
75Var
76 StartupInfo: TStartupInfo;
77 ProcessInfo: TProcessInformation;
78 rc: DWORD;
79 NameAndArgs: string;
80
81 pipeServer: hFile;
82 buffer: array[ 0..PipeBufferSize ] of char;
83 bytesRead: DWORD;
84 SecAttrs: TSecurityAttributes;
85 pipeClient: hFile;
86Begin
87
88 pipeServer := 0;
89 pipeClient := 0;
90 try
91 NameAndArgs := ProgramName+' '+Parameters;
92
93 // Initialize some variables to create a process
94 ZeroMemory( @StartupInfo, SizeOf( StartupInfo ) );
95
96 StartupInfo.cb := SizeOf( StartupInfo );
97 StartupInfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
98 StartupInfo.wShowWindow := SW_HIDE;
99
100 if Assigned( PrintOutput ) then
101 begin
102 // Allow the started process to inherit our handles
103 FillChar( SecAttrs, SizeOf( SecAttrs ), #0);
104 SecAttrs.nLength := SizeOf(SecAttrs);
105 SecAttrs.lpSecurityDescriptor := nil;
106 SecAttrs.bInheritHandle := TRUE;
107
108 // Create a pipe
109 pipeServer := CreateNamedPipe( PipeName,
110 PIPE_ACCESS_DUPLEX,
111 PIPE_TYPE_BYTE or PIPE_NOWAIT,
112 PIPE_UNLIMITED_INSTANCES,
113 PipeBufferSize, //out buffer
114 PipeBufferSize, // in buffer
115 100, // default timeout (ms)
116 Addr( SecAttrs ) );
117
118 // Get a handle to the other (client) end of the pipe
119 pipeClient := CreateFile( PipeName,
120 GENERIC_READ or GENERIC_WRITE,
121 FILE_SHARE_READ or FILE_SHARE_WRITE,
122 Addr( SecAttrs ),
123 OPEN_EXISTING,
124 FILE_ATTRIBUTE_NORMAL,
125 0 );
126
127 // setup the process to write into the other end
128 StartupInfo.hStdOutput := pipeClient;
129 StartupInfo.hStdError := pipeClient;
130 end;
131
132 // Create the process
133 if not CreateProcess( Nil, // use next param for exe name
134 PChar( NameAndArgs ), // command line
135 Nil, // no security attributes
136 Nil, // no thread security attributes
137 True, // do inherit handles
138 CREATE_NEW_PROCESS_GROUP, // so we can send
139 // it Ctrl signals
140 Nil, // no new environment
141 PChar( WorkingDir ), // directory
142 StartupInfo,
143 ProcessInfo ) then
144 begin
145 Result := GetLastError;
146 PrintOutput( 'Could not run '+NameAndArgs );
147 PrintOutput( 'Windows error text: ' + GetAPIErrorString( Result ) );
148 ResultCode := 1;
149 exit;
150 end;
151
152 while true do
153 begin
154 if Assigned( TerminateCheck ) then
155 if TerminateCheck then
156 begin
157 GenerateConsoleCtrlEvent( CTRL_BREAK_EVENT, ProcessInfo.dwProcessID );
158 ResultCode := 1;
159 Result := 0;
160 exit;
161 end;
162
163 // Wait 1 second to see if it finishes...
164 rc := WaitForSingleObject( ProcessInfo.hProcess, 1000 );
165
166 if Assigned( PrintOutput ) then
167 begin
168 repeat
169 // Read the output from our end of the pipe
170 ReadFile( pipeServer,
171 buffer,
172 PipeBufferSize,
173 bytesRead,
174 nil );
175 buffer[ bytesRead ] := #0; // null terminate
176 if bytesRead > 0 then
177 PrintOutput( buffer );
178
179 until bytesRead = 0;
180
181 end;
182
183 if rc <> WAIT_TIMEOUT then
184 begin
185 // finished
186 GetExitCodeProcess( ProcessInfo.hProcess,
187 ResultCode );
188 Result := 0;
189 // terminate loop
190 exit;
191 end;
192 end;
193 finally
194 if pipeClient <> 0 then
195 CloseHandle( pipeClient );
196 if pipeServer <> 0 then
197 CloseHandle( pipeServer );
198 end;
199
200end;
201{$endif}
202
203{$ifdef os2}
204Var
205 psd: STARTDATA;
206 SessID: LONGWORD;
207 apid: LONGWORD;
208 PgmName: CSTRING;
209 ObjBuf: CSTRING;
210 rc: Integer;
211
212 Args: CSTRING;
213
214 TerminationQueue:HQueue;
215 QueueName: CSTRING;
216 QueueRequest: REQUESTDATA;
217 DataLength: ULONG;
218 DataAddress: ^TermQResults;
219 ElementCode: ULONG;
220 NoWait: BOOL;
221 ElemPriority: BYTE;
222 SemName: CString;
223 SemHandle: HEV;
224
225 SemPostCount: ULONG;
226Begin
227 QueueName := '\QUEUES\SIBYL_EXECUTE_TERMQ'
228 + IntToStr( GetCurrentProcessID );
229 rc := DosCreateQueue( TerminationQueue,
230 QUE_FIFO, // normal queue
231 QueueName );
232 if rc <> 0 then
233 begin
234 Result := rc;
235 exit;
236 end;
237
238 psd.Length := SizeOf( psd );
239 psd.Related := SSF_RELATED_CHILD; // yes we want to know about it
240 psd.FgBg := SSF_FGBG_FORE; // run in foreground
241 psd.TraceOpt := SSF_TRACEOPT_NONE; // no tracing!
242
243 PgmName := ProgramName; // copy to a cstring
244 psd.PgmName := @PgmName; // program
245 psd.PgmTitle := @PgmName; // window title
246
247 Args :=parameters; // copy to a cstring
248 psd.PgmInputs := @Args; //arguments
249 psd.TermQ := @QueueName; // Termination Queue name
250 psd.Environment := NIL; // no special environment to pass
251 psd.InheritOpt := SSF_INHERTOPT_PARENT;
252 // use parent file handles
253 // AND (more importantly) parent's current drive and dir
254 psd.SessionType := SSF_TYPE_DEFAULT; // whatever the exe says
255 psd.IconFile := NIL; // no icon file
256 psd.PgmHandle := 0; // no program handle
257 psd.PgmControl := 0; // SSF_CONTROL_MINIMIZE; // run minimized
258 psd.InitXPos := 0; // position x
259 psd.InitYPos := 0; // position y
260 psd.Reserved := 0; // blah
261 psd.ObjectBuffer := @ObjBuf; // put errors here
262 psd.ObjectBuffLen := 100; // up to 100 chars
263
264 rc := DosStartSession( psd, SessID, apid );
265
266 if ( rc <> 0 )
267 // but we don't care if it just started in the background!
268 and ( rc <> ERROR_SMG_START_IN_BACKGROUND )
269 then
270 begin
271 Result := rc;
272 DosCloseQueue( TerminationQueue );
273 exit;
274 end;
275
276 // DosCloseQueue( TerminationQueue );
277 // exit;
278
279 // create a semaphore so we can check the queue!!
280 SemName := '\SEM32\SIBYL_EXECUTE_TERMQ'
281 + IntToStr( GetCurrentProcessID );
282 rc := DosCreateEventSem( SemName,
283 SemHandle,
284 0,
285 FALSE );
286 if ( rc <> 0 ) then
287 begin
288 Result := rc;
289 DosCloseQueue( TerminationQueue );
290 exit;
291 end;
292
293 // OK, we started it
294 Result := 0;
295
296 ElementCode := 0; // get element at front of queue
297 NoWait := True; // don't wait for data: so we supply semaphore instead
298
299 // assocaite the semaphore with the queue, don't remove item if it's already there
300 rc := DosPeekQueue( TerminationQueue,
301 QueueRequest,
302 DataLength,
303 DataAddress,
304 ElementCode,
305 NoWait,
306 ElemPriority,
307 SemHandle );
308
309 repeat
310 rc := DosQueryEventSem( SemHandle, SemPostCount );
311
312 // Handle PM messages (including to our own app!)
313 Application.ProcessMessages;
314
315 // Give up CPU briefly so we don't appear too greedy when idle.
316 DosSleep( 1 );
317
318 until SemPostCount > 0; // until semaphore is posted, indicating an item in the TermQ
319
320 // The program has terminated.
321 // Now read the item
322 rc := DosReadQueue( TerminationQueue,
323 QueueRequest,
324 DataLength,
325 DataAddress,
326 ElementCode,
327 NoWait,
328 ElemPriority,
329 SemHandle );
330
331 ResultCode := DataAddress^.ResultCode;
332 DosCloseQueue( TerminationQueue );
333 // Free the memory used by the queue element
334 DosFreeMem( DataAddress );
335
336 // Close semaphore
337 DosCloseEventSem( SemHandle );
338
339End;
340
341{$endif}
342
343{$ifdef os2}
344Function LaunchProgram( ProgramName: string;
345 Parameters: string;
346 WorkingDir: string ): APIRET;
347Var
348 psd: STARTDATA;
349 apid: LONGWORD;
350 PgmName: CSTRING;
351 ObjBuf: CSTRING;
352 rc: Integer;
353
354 Args: CSTRING;
355 ProgramHandle: TProgramHandle;
356Begin
357 psd.Length := SizeOf( psd );
358 psd.Related := SSF_RELATED_INDEPENDENT; // don't want to know about it or own it
359 psd.FgBg := SSF_FGBG_FORE; // run in foreground
360 psd.TraceOpt := SSF_TRACEOPT_NONE; // no tracing!
361
362 PgmName := ProgramName; // copy to a cstring
363 psd.PgmName := @PgmName; // program
364 psd.PgmTitle := @PgmName; // window title
365
366 Args := parameters; // copy to a cstring
367 psd.PgmInputs := @Args; //arguments
368 psd.TermQ := nil; // Termination Queue name
369 psd.Environment := NIL; // no special environment to pass
370 psd.InheritOpt := SSF_INHERTOPT_PARENT;
371 // use parent file handles
372 // AND (more importantly) parent's current drive and dir
373 psd.SessionType := SSF_TYPE_DEFAULT; // whatever the exe says
374 psd.IconFile := NIL; // no icon file
375 psd.PgmHandle := 0; // no program handle
376 psd.PgmControl := 0; // SSF_CONTROL_MINIMIZE; // run minimized
377 psd.InitXPos := 0; // position x
378 psd.InitYPos := 0; // position y
379 psd.Reserved := 0; // blah
380 psd.ObjectBuffer := @ObjBuf; // put errors here
381 psd.ObjectBuffLen := 100; // up to 100 chars
382
383 rc := DosStartSession( psd, ProgramHandle, apid );
384
385 // we don't care if it just started in the background!
386 if rc = ERROR_SMG_START_IN_BACKGROUND then
387 rc := 0;
388end;
389{$endif}
390
391end.
Note: See TracBrowser for help on using the repository browser.