source: trunk/Library/RunProgramUnit.pas@ 394

Last change on this file since 394 was 394, checked in by RBRi, 9 years ago

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