source: trunk/Library/RunProgramUnit.pas@ 17

Last change on this file since 17 was 17, checked in by RBRi, 19 years ago

+ Library
  • Property svn:eol-style set to native
File size: 11.3 KB
Line 
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 PgmTitle: CSTRING;
209 PgmName: CSTRING;
210 ObjBuf: CSTRING;
211 rc: Integer;
212
213 Args: CSTRING;
214 ReportTypeStr: CSTRING;
215
216 TerminationQueue:HQueue;
217 QueueName: CSTRING;
218 QueueRequest: REQUESTDATA;
219 DataLength: ULONG;
220 DataAddress: ^TermQResults;
221 ElementCode: ULONG;
222 NoWait: BOOL;
223 ElemPriority: BYTE;
224 SemName: CString;
225 SemHandle: HEV;
226 OwningPID: PID;
227
228 SemPostCount: ULONG;
229Begin
230 QueueName := '\QUEUES\SIBYL_EXECUTE_TERMQ'
231 + IntToStr( GetCurrentProcessID );
232 rc := DosCreateQueue( TerminationQueue,
233 QUE_FIFO, // normal queue
234 QueueName );
235 if rc <> 0 then
236 begin
237 Result := rc;
238 exit;
239 end;
240
241 psd.Length := SizeOf( psd );
242 psd.Related := SSF_RELATED_CHILD; // yes we want to know about it
243 psd.FgBg := SSF_FGBG_FORE; // run in foreground
244 psd.TraceOpt := SSF_TRACEOPT_NONE; // no tracing!
245
246 PgmName := ProgramName; // copy to a cstring
247 psd.PgmName := @PgmName; // program
248 psd.PgmTitle := @PgmName; // window title
249
250 Args :=parameters; // copy to a cstring
251 psd.PgmInputs := @Args; //arguments
252 psd.TermQ := @QueueName; // Termination Queue name
253 psd.Environment := NIL; // no special environment to pass
254 psd.InheritOpt := SSF_INHERTOPT_PARENT;
255 // use parent file handles
256 // AND (more importantly) parent's current drive and dir
257 psd.SessionType := SSF_TYPE_DEFAULT; // whatever the exe says
258 psd.IconFile := NIL; // no icon file
259 psd.PgmHandle := 0; // no program handle
260 psd.PgmControl := 0; // SSF_CONTROL_MINIMIZE; // run minimized
261 psd.InitXPos := 0; // position x
262 psd.InitYPos := 0; // position y
263 psd.Reserved := 0; // blah
264 psd.ObjectBuffer := @ObjBuf; // put errors here
265 psd.ObjectBuffLen := 100; // up to 100 chars
266
267 rc := DosStartSession( psd, SessID, apid );
268
269 if ( rc <> 0 )
270 // but we don't care if it just started in the background!
271 and ( rc <> ERROR_SMG_START_IN_BACKGROUND )
272 then
273 begin
274 Result := rc;
275 DosCloseQueue( TerminationQueue );
276 exit;
277 end;
278
279 // DosCloseQueue( TerminationQueue );
280 // exit;
281
282 // create a semaphore so we can check the queue!!
283 SemName := '\SEM32\SIBYL_EXECUTE_TERMQ'
284 + IntToStr( GetCurrentProcessID );
285 rc := DosCreateEventSem( SemName,
286 SemHandle,
287 0,
288 FALSE );
289 if ( rc <> 0 ) then
290 begin
291 Result := rc;
292 DosCloseQueue( TerminationQueue );
293 exit;
294 end;
295
296 // OK, we started it
297 Result := 0;
298
299 ElementCode := 0; // get element at front of queue
300 NoWait := True; // don't wait for data: so we supply semaphore instead
301
302 // assocaite the semaphore with the queue, don't remove item if it's already there
303 rc := DosPeekQueue( TerminationQueue,
304 QueueRequest,
305 DataLength,
306 DataAddress,
307 ElementCode,
308 NoWait,
309 ElemPriority,
310 SemHandle );
311
312 repeat
313 rc := DosQueryEventSem( SemHandle, SemPostCount );
314
315 // Handle PM messages (including to our own app!)
316 Application.ProcessMessages;
317
318 // Give up CPU briefly so we don't appear too greedy when idle.
319 DosSleep( 1 );
320
321 until SemPostCount > 0; // until semaphore is posted, indicating an item in the TermQ
322
323 // The program has terminated.
324 // Now read the item
325 rc := DosReadQueue( TerminationQueue,
326 QueueRequest,
327 DataLength,
328 DataAddress,
329 ElementCode,
330 NoWait,
331 ElemPriority,
332 SemHandle );
333
334 ResultCode := DataAddress^.ResultCode;
335 DosCloseQueue( TerminationQueue );
336 // Free the memory used by the queue element
337 DosFreeMem( DataAddress );
338
339 // Close semaphore
340 DosCloseEventSem( SemHandle );
341
342End;
343
344{$endif}
345
346{$ifdef os2}
347Function LaunchProgram( ProgramName: string;
348 Parameters: string;
349 WorkingDir: string ): APIRET;
350Var
351 psd: STARTDATA;
352 SessID: LONGWORD;
353 apid: LONGWORD;
354 PgmTitle: CSTRING;
355 PgmName: CSTRING;
356 ObjBuf: CSTRING;
357 rc: Integer;
358
359 Args: CSTRING;
360 ReportTypeStr: CSTRING;
361 ProgramHandle: TProgramHandle;
362Begin
363 psd.Length := SizeOf( psd );
364 psd.Related := SSF_RELATED_INDEPENDENT; // don't want to know about it or own it
365 psd.FgBg := SSF_FGBG_FORE; // run in foreground
366 psd.TraceOpt := SSF_TRACEOPT_NONE; // no tracing!
367
368 PgmName := ProgramName; // copy to a cstring
369 psd.PgmName := @PgmName; // program
370 psd.PgmTitle := @PgmName; // window title
371
372 Args := parameters; // copy to a cstring
373 psd.PgmInputs := @Args; //arguments
374 psd.TermQ := nil; // Termination Queue name
375 psd.Environment := NIL; // no special environment to pass
376 psd.InheritOpt := SSF_INHERTOPT_PARENT;
377 // use parent file handles
378 // AND (more importantly) parent's current drive and dir
379 psd.SessionType := SSF_TYPE_DEFAULT; // whatever the exe says
380 psd.IconFile := NIL; // no icon file
381 psd.PgmHandle := 0; // no program handle
382 psd.PgmControl := 0; // SSF_CONTROL_MINIMIZE; // run minimized
383 psd.InitXPos := 0; // position x
384 psd.InitYPos := 0; // position y
385 psd.Reserved := 0; // blah
386 psd.ObjectBuffer := @ObjBuf; // put errors here
387 psd.ObjectBuffLen := 100; // up to 100 chars
388
389 rc := DosStartSession( psd, ProgramHandle, apid );
390
391 // we don't care if it just started in the background!
392 if rc = ERROR_SMG_START_IN_BACKGROUND then
393 rc := 0;
394end;
395{$endif}
396
397end.
Note: See TracBrowser for help on using the repository browser.