← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to fcl/inc/process.pp

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2004-08-12 16:29:37 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040812162937-moo8ulvysp1ln771
Tags: 1.9.4-5
http://bugs.debian.org/265265
fp-compiler: needs ld, adding dependency on binutils.  (Closes: #265265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fcl/inc/process.pp
1
1
{
2
 
    $Id: process.pp,v 1.1 2000/07/13 06:31:31 michael Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 1999-2000 by Michael Van Canneyt
 
2
    $Id: process.pp,v 1.19 2004/02/03 08:12:22 michael Exp $
 
3
    This file is part of the Free Component Library (FCL)
 
4
    Copyright (c) 1999-2000 by the Free Pascal development team
5
5
 
6
6
    See the file COPYING.FPC, included in this distribution,
7
7
    for details about the copyright.
12
12
 
13
13
 **********************************************************************}
14
14
 
15
 
unit Process;
16
 
 
17
 
{$mode delphi}
18
 
{$H+}
 
15
{$mode objfpc}
 
16
{$h+}
 
17
unit process;
19
18
 
20
19
interface
21
20
 
22
 
Uses Classes,Pipes;
23
 
 
24
 
Type
25
 
   THandle = Longint;
26
 
 
27
 
Type
28
 
  TProcessOptions = (poExecuteOnCreate,poRunSuspended,poUsePipes,
29
 
                     poNoConsole,poStderrToOutPut,poWaitOnExit);
30
 
 
31
 
  TCreateOptions = Set of TPRocessOptions;
32
 
 
33
 
  TProcess = Class (TObject)
34
 
    Private
35
 
      FShowWindow : Boolean;
36
 
      FFillAttribute,
37
 
      FWindowColumns,
38
 
      FWindowHeight,
39
 
      FWindowLeft,
40
 
      FWindowRows,
41
 
      FWindowTop,
42
 
      FWindowWidth : Longint;
43
 
      FWindowRect  : TRect;
44
 
      FApplicationName : string;
45
 
      FChildErrorStream : TOutPutPipeStream;
46
 
      FChildInputSTream : TInputPipeStream;
47
 
      FChildOutPutStream : TOutPutPipeStream;
48
 
      FConsoleTitle : String;
49
 
      FCreateOptions : TCreateOptions;
50
 
      FCreationFlags : Cardinal;
51
 
      FCommandLine : String;
52
 
      FCurrentDirectory : String;
53
 
      FDeskTop : String;
54
 
      FEnvironment : Pointer;
55
 
      FExitCode : Cardinal;
56
 
      FPID : Longint;
57
 
      FThreadHandle,
58
 
      FHandle : THandle;
59
 
      FInherithandles : LongBool;
60
 
      FParentErrorStream : TInputPipeStream;
61
 
      FParentInputSTream : TInputPipeStream;
62
 
      FParentOutputStream : TOutPutPipeStream;
63
 
      FPrepared : Boolean;
64
 
      FRunning : Boolean;
65
 
      Procedure FreeStreams;
66
 
      Function GetExitStatus : Integer;
67
 
      Function GetRunning : Boolean;
68
 
      Function GetWindowRect : TRect;
69
 
      Procedure SetWindowRect (Value : TRect);
70
 
    Public
71
 
      Constructor Create (Const ACommandline : String;
72
 
                          Options : TCreateOptions);
73
 
      Destructor Destroy; override;
74
 
      Procedure Execute; virtual;
75
 
      Function Resume : Integer; virtual;
76
 
      Function Suspend : Integer; virtual;
77
 
      Function Terminate (AExitCode : Integer): Boolean; virtual;
78
 
      Function WaitOnExit : DWord;
79
 
 
80
 
      Property ApplicationName : String Read FApplicationname
81
 
                                        Write FApplicationname;
82
 
      Property CommandLine : String Read FCommandLine;
83
 
      Property ConsoleTitle : String Read FConsoleTitle Write FConsoleTitle;
84
 
      Property CurrentDirectory : String Read FCurrentDirectory
85
 
                                       Write FCurrentDirectory;
86
 
      Property CreateOptions : TCreateOptions Read FCreateOptions;
87
 
      Property CreationFlags : Cardinal Read FCreationFlags Write FCreationFlags;
88
 
      Property DeskTop : String Read FDeskTop Write FDeskTop;
89
 
      Property Environment : Pointer Read FEnvironment Write FEnvironment;
90
 
      Property ExitStatus : Integer Read GetExitStatus;
91
 
      Property FillAttribute : Longint Read FFillAttribute Write FFillAttribute;
92
 
      Property Handle : THandle Read FHandle;
93
 
      Property ThreadHandle : THandle Read FThreadHandle;
94
 
      Property PID : Longint;
95
 
      Property Input : TOutPutPipeStream Read FParentOutPutStream;
96
 
      Property InheritHandles : LongBool Read FInheritHandles;
97
 
      Property OutPut : TInputPipeStream Read FParentInputStream;
98
 
      Property Running : Boolean Read GetRunning;
99
 
      Property ShowWindow : Boolean Read FShowWindow Write FShowWindow;
100
 
      Property StdErr : TinputPipeStream Read FParentErrorStream;
101
 
      Property WindowColumns : Longint Read FWindowColumns Write FWindowColumns;
102
 
      Property WindowHeight : Longint Read FWindowHeight Write FWindowHeight;
103
 
      Property WindowLeft : Longint Read FWindowLeft Write FWindowLeft;
104
 
      Property WindowRows : Longint Read FWindowRows Write FWindowRows;
105
 
      Property WindowTop : Longint Read FWindowTop  Write FWindowTop;
106
 
      Property WindowWidth : Longint Read FWindowWidth Write FWindowWidth;
107
 
      Property WindowRect : Trect Read GetWindowRect  Write SetWindowRect;
108
 
    end;
109
 
 
 
21
Uses Classes,
 
22
     pipes,
 
23
{$ifdef Unix}
 
24
{$ifdef ver1_0}
 
25
     Linux,
 
26
{$else}
 
27
     Baseunix,unix,
 
28
{$endif}
 
29
{$else}
 
30
     Windows,
 
31
{$endif}
 
32
     SysUtils;
 
33
 
 
34
Type
 
35
  TProcessOption = (poRunSuspended,poWaitOnExit,
 
36
                    poUsePipes,poStderrToOutPut,
 
37
                    poNoConsole,poNewConsole,
 
38
                    poDefaultErrorMode,poNewProcessGroup,
 
39
                    poDebugProcess,poDebugOnlyThisProcess);
 
40
 
 
41
  TShowWindowOptions = (swoNone,swoHIDE,swoMaximize,swoMinimize,swoRestore,swoShow,
 
42
                        swoShowDefault,swoShowMaximized,swoShowMinimized,
 
43
                        swoshowMinNOActive,swoShowNA,swoShowNoActivate,swoShowNormal);
 
44
 
 
45
  TStartupOption = (suoUseShowWindow,suoUseSize,suoUsePosition,
 
46
                    suoUseCountChars,suoUseFillAttribute);
 
47
 
 
48
  TProcessPriority = (ppHigh,ppIdle,ppNormal,ppRealTime);
 
49
 
 
50
  TProcessOptions = Set of TPRocessOption;
 
51
  TstartUpoptions = set of TStartupOption;
 
52
 
 
53
{$ifdef unix}
 
54
Const
 
55
  STARTF_USESHOWWINDOW    = 1;    // Ignored
 
56
  STARTF_USESIZE          = 2;
 
57
  STARTF_USEPOSITION      = 4;
 
58
  STARTF_USECOUNTCHARS    = 8;    // Ignored
 
59
  STARTF_USEFILLATTRIBUTE = $10;
 
60
  STARTF_RUNFULLSCREEN    = $20;  // Ignored
 
61
  STARTF_FORCEONFEEDBACK  = $40;  // Ignored
 
62
  STARTF_FORCEOFFFEEDBACK = $80;  // Ignored
 
63
  STARTF_USESTDHANDLES    = $100; // Ignored
 
64
  STARTF_USEHOTKEY        = $200; // Ignored
 
65
 
 
66
Type
 
67
  PProcessInformation = ^TProcessInformation;
 
68
  TProcessInformation = record
 
69
    hProcess: THandle;
 
70
    hThread: THandle;
 
71
    dwProcessId: DWORD;
 
72
    dwThreadId: DWORD;
 
73
  end;
 
74
 
 
75
  PStartupInfo = ^TStartupInfo;
 
76
  TStartupInfo = Record
 
77
    cb: DWORD;
 
78
    lpReserved: Pointer;
 
79
    lpDesktop: Pointer;
 
80
    lpTitle: Pointer;
 
81
    dwX: DWORD;
 
82
    dwY: DWORD;
 
83
    dwXSize: DWORD;
 
84
    dwYSize: DWORD;
 
85
    dwXCountChars: DWORD;
 
86
    dwYCountChars: DWORD;
 
87
    dwFillAttribute: DWORD;
 
88
    dwFlags: DWORD;
 
89
    wShowWindow: Word;
 
90
    cbReserved2: Word;
 
91
    lpReserved2: PByte;
 
92
    hStdInput: THandle;
 
93
    hStdOutput: THandle;
 
94
    hStdError: THandle;
 
95
  end;
 
96
 
 
97
  PSecurityAttributes = ^TSecurityAttributes;
 
98
  TSecurityAttributes = Record
 
99
    nlength : Integer;
 
100
    lpSecurityDescriptor : Pointer;
 
101
    BinheritHandle : Boolean;
 
102
  end;
 
103
 
 
104
Const piInheritablePipe : TSecurityAttributes = (
 
105
                           nlength:SizeOF(TSecurityAttributes);
 
106
                           lpSecurityDescriptor:Nil;
 
107
                           Binherithandle:True);
 
108
      piNonInheritablePipe : TSecurityAttributes = (
 
109
                             nlength:SizeOF(TSecurityAttributes);
 
110
                             lpSecurityDescriptor:Nil;
 
111
                             Binherithandle:False);
 
112
 
 
113
{$endif}
 
114
Type
 
115
 
 
116
  TProcess = Class (TComponent)
 
117
  Private
 
118
{$ifndef unix}
 
119
    FAccess : Cardinal;
 
120
{$endif}
 
121
    FApplicationName : string;
 
122
    FChildErrorStream : TOutPutPipeStream;
 
123
    FChildInputSTream : TInputPipeStream;
 
124
    FChildOutPutStream : TOutPutPipeStream;
 
125
    FConsoleTitle : String;
 
126
    FProcessOptions : TProcessOptions;
 
127
    FStartUpOptions : TStartupOptions;
 
128
    FCommandLine : String;
 
129
    FCurrentDirectory : String;
 
130
    FDeskTop : String;
 
131
    FEnvironment : Tstrings;
 
132
    FExitCode : Cardinal;
 
133
    FHandle : THandle;
 
134
    FShowWindow : TShowWindowOptions;
 
135
    FInherithandles : LongBool;
 
136
    FParentErrorStream : TInputPipeStream;
 
137
    FParentInputSTream : TInputPipeStream;
 
138
    FParentOutputStream : TOutPutPipeStream;
 
139
    FRunning : Boolean;
 
140
    FThreadAttributes  : PSecurityAttributes;
 
141
    FProcessAttributes : PSecurityAttributes;
 
142
    FProcessInformation : TProcessInformation;
 
143
    FPRocessPriority : TProcessPriority;
 
144
    FStartupInfo : TStartupInfo;
 
145
    Procedure FreeStreams;
 
146
    Function  GetExitStatus : Integer;
 
147
    Function  GetHandle : THandle;
 
148
    Function  GetRunning : Boolean;
 
149
    Function  GetProcessAttributes : TSecurityAttributes;
 
150
    Function  GetThreadAttributes : TSecurityAttributes;
 
151
    Procedure SetProcessAttributes (Value : TSecurityAttributes);
 
152
    Procedure SetThreadAttributes (Value : TSecurityAttributes);
 
153
    Function  GetWindowRect : TRect;
 
154
    Procedure SetWindowRect (Value : TRect);
 
155
    Procedure SetFillAttribute (Value : Cardinal);
 
156
    Procedure SetShowWindow (Value : TShowWindowOptions);
 
157
    Procedure SetWindowColumns (Value : Cardinal);
 
158
    Procedure SetWindowHeight (Value : Cardinal);
 
159
    Procedure SetWindowLeft (Value : Cardinal);
 
160
    Procedure SetWindowRows (Value : Cardinal);
 
161
    Procedure SetWindowTop (Value : Cardinal);
 
162
    Procedure SetWindowWidth (Value : Cardinal);
 
163
    procedure CreateStreams;
 
164
    function GetCreationFlags: Cardinal;
 
165
    function GetStartupFlags: Cardinal;
 
166
    procedure SetApplicationname(const Value: String);
 
167
    procedure SetPRocessOptions(const Value: TProcessOptions);
 
168
    procedure SetActive(const Value: Boolean);
 
169
    procedure SetEnvironment(const Value: TStrings);
 
170
{$ifdef unix}
 
171
    function PeekLinuxExitStatus: Boolean;
 
172
{$endif}
 
173
  Public
 
174
    Constructor Create (AOwner : TComponent);override;
 
175
    Destructor Destroy; override;
 
176
    Procedure Execute; virtual;
 
177
    Function Resume : Integer; virtual;
 
178
    Function Suspend : Integer; virtual;
 
179
    Function Terminate (AExitCode : Integer): Boolean; virtual;
 
180
    Function WaitOnExit : DWord;
 
181
    Property WindowRect : Trect Read GetWindowRect Write SetWindowRect;
 
182
    Property StartupInfo : TStartupInfo Read FStartupInfo;
 
183
    Property ProcessAttributes : TSecurityAttributes  Read GetProcessAttributes  Write SetProcessAttributes;
 
184
    Property ProcessInformation : TProcessInformation Read FPRocessInformation;
 
185
    Property Handle : THandle Read FProcessInformation.hProcess;
 
186
    Property ThreadHandle : THandle Read FprocessInformation.hThread;
 
187
    Property Input  : TOutPutPipeStream Read FParentOutPutStream;
 
188
    Property OutPut : TInputPipeStream  Read FParentInputStream;
 
189
    Property StdErr : TinputPipeStream  Read FParentErrorStream;
 
190
    Property ExitStatus : Integer Read GetExitStatus;
 
191
    Property InheritHandles : LongBool Read FInheritHandles Write FInheritHandles;
 
192
    Property ThreadAttributes : TSecurityAttributes Read GetThreadAttributes Write SetThreadAttributes;
 
193
  Published
 
194
    Property Active : Boolean Read Getrunning Write SetActive;
 
195
    Property ApplicationName : String Read FApplicationname Write SetApplicationname;
 
196
    Property CommandLine : String Read FCommandLine Write FCommandLine;
 
197
    Property ConsoleTitle : String Read FConsoleTitle Write FConsoleTitle;
 
198
    Property CurrentDirectory : String Read FCurrentDirectory Write FCurrentDirectory;
 
199
    Property DeskTop : String Read FDeskTop Write FDeskTop;
 
200
    Property Environment : TStrings Read FEnvironment Write SetEnvironment;
 
201
    Property FillAttribute : Cardinal Read FStartupInfo.dwFillAttribute Write SetFillAttribute;
 
202
    Property Options : TProcessOptions Read FProcessOptions Write SetPRocessOptions;
 
203
    Property Priority : TProcessPriority Read FProcessPriority Write FProcessPriority;
 
204
    Property StartUpOptions : TStartUpOptions Read FStartUpOptions Write FStartupOptions;
 
205
    Property Running : Boolean Read GetRunning;
 
206
    Property ShowWindow : TShowWindowOptions Read FShowWindow Write SetShowWindow;
 
207
    Property WindowColumns : Cardinal Read FStartupInfo.dwXCountchars Write SetWindowColumns;
 
208
    Property WindowHeight : Cardinal Read FStartupInfo.dwYsize Write SetWindowHeight;
 
209
    Property WindowLeft : Cardinal Read FStartupInfo.dwx Write SetWindowLeft;
 
210
    Property WindowRows : Cardinal Read FStartupInfo.dwYcountChars Write SetWindowRows;
 
211
    Property WindowTop : Cardinal Read FStartupInfo.dwy Write SetWindowTop ;
 
212
    Property WindowWidth : Cardinal Read FStartupInfo.dwXsize Write SetWindowWidth;
 
213
  end;
 
214
 
 
215
{$ifdef unix}
 
216
Const
 
217
  PriorityConstants : Array [TProcessPriority] of Integer =
 
218
                      (20,20,0,-20);
 
219
 
 
220
Const
 
221
  GeometryOption : String = '-geometry';
 
222
  TitleOption : String ='-title';
 
223
 
 
224
{$else}
 
225
Const
 
226
  PriorityConstants : Array [TProcessPriority] of Cardinal =
 
227
                      (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS,
 
228
                       NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS);
 
229
{$endif}
110
230
implementation
111
231
 
112
 
{$i process.inc}
113
 
 
114
 
Constructor TProcess.Create (Const ACommandline : String;
115
 
                    Options : TCreateOptions);
 
232
Constructor TProcess.Create (AOwner : TComponent);
116
233
begin
117
 
  Inherited create;
118
 
  FCreateOptions:=Options;
119
 
  FCommandLine:=ACommandLine;
 
234
  Inherited;
 
235
{$ifndef unix}
 
236
  FAccess:=PROCESS_ALL_ACCESS;
 
237
{$endif}
 
238
  FProcessPriority:=ppNormal;
 
239
  FShowWindow:=swoNone;
 
240
  FStartupInfo.cb:=SizeOf(TStartupInfo);
120
241
  FInheritHandles:=True;
121
 
  FFillAttribute := -1;
122
 
  FWindowColumns := -1;
123
 
  FWindowHeight := -1;
124
 
  FWindowLeft := -1;
125
 
  FWindowRows := -1;
126
 
  FWindowTop := -1;
127
 
  FWindowWidth := -1;
128
 
  If poExecuteOnCreate in FCreateOptions then
129
 
    execute;
 
242
  FEnvironment:=TStringList.Create;
130
243
end;
131
244
 
132
245
Destructor TProcess.Destroy;
133
246
 
134
247
begin
 
248
  If assigned (FProcessAttributes) then Dispose (FPRocessAttributes);
 
249
  If assigned (FThreadAttributes) then Dispose (FThreadAttributes);
 
250
  FEnvironment.Free;
135
251
  FreeStreams;
 
252
  Inherited Destroy;
136
253
end;
137
254
 
138
255
Procedure TProcess.FreeStreams;
139
256
 
 
257
var FreedStreams: TList;
 
258
 
 
259
  procedure FreeStream(var AnObject: THandleStream);
 
260
 
 
261
  begin
 
262
    if (AnObject<>Nil) and (FreedStreams.IndexOf(AnObject)<0) then
 
263
      begin
 
264
      FileClose(AnObject.Handle);
 
265
      FreedStreams.Add(AnObject);
 
266
      AnObject.Free;
 
267
      end;
 
268
    AnObject:=nil;
 
269
  end;
 
270
 
140
271
begin
141
 
  if FChildErrorStream<>FChildoutputStream then
142
 
    begin
143
 
    FChildErrorStream.free;
144
 
    FParentErrorStream.free;
145
 
    end;
146
 
  FParentInputSTream.Free;
147
 
  FParentOutputStream.Free;
148
 
  FChildInputSTream.Free;
149
 
  FChildOutPutStream.Free;
 
272
  FreedStreams:=TList.Create;
 
273
  try
 
274
    FreeStream(FParentErrorStream);
 
275
    FreeStream(FParentInputStream);
 
276
    FreeStream(FParentOutputStream);
 
277
    FreeStream(FChildErrorStream);
 
278
    FreeStream(FChildInputStream);
 
279
    FreeStream(FChildOutputStream);
 
280
  finally
 
281
    FreedStreams.Free;
 
282
  end;
150
283
end;
151
284
 
152
285
Function TProcess.GetExitStatus : Integer;
153
286
 
154
287
begin
155
 
{
156
288
  If FRunning then
157
 
    GetExitCodeProcess(Handle,@FExitCode);
158
 
}
 
289
{$ifdef unix}
 
290
    PeekLinuxExitStatus;
 
291
{$else}
 
292
    GetExitCodeProcess(Handle,FExitCode);
 
293
{$endif}
159
294
  Result:=FExitCode;
160
295
end;
161
296
 
 
297
Function TProcess.GetHandle : THandle;
 
298
 
 
299
begin
 
300
{$ifndef unix}
 
301
  If FHandle=0 Then
 
302
    FHandle:=OpenProcess (FAccess,True,FProcessInformation.dwProcessId);
 
303
{$endif}
 
304
  Result:=FHandle
 
305
end;
 
306
 
 
307
Function TProcess.GetProcessAttributes : TSecurityAttributes;
 
308
 
 
309
Var P : PSecurityAttributes;
 
310
 
 
311
begin
 
312
  IF not Assigned(FProcessAttributes) then
 
313
    begin
 
314
    // Provide empty dummy value;
 
315
    New(p);
 
316
    Fillchar(p^,Sizeof(TSecurityAttributes),0);
 
317
    Result:=p^;
 
318
    end
 
319
  else
 
320
    REsult:=FProcessAttributes^;
 
321
end;
 
322
 
 
323
{$ifdef unix}
 
324
Function TProcess.PeekLinuxExitStatus : Boolean;
 
325
 
 
326
begin
 
327
  Result:={$ifdef VER1_0}WaitPID{$else}fpWaitPid{$endif}(Handle,@FExitCode,WNOHANG)=Handle;
 
328
  If Result then
 
329
    FExitCode:=wexitstatus(FExitCode)
 
330
  else
 
331
    FexitCode:=0;
 
332
end;
 
333
{$endif}
 
334
 
 
335
Function TProcess.GetRunning : Boolean;
 
336
 
 
337
begin
 
338
  IF FRunning then
 
339
    begin
 
340
{$ifdef unix}
 
341
    FRunning:=Not PeekLinuxExitStatus;
 
342
{$else}
 
343
    Frunning:=GetExitStatus=Still_Active;
 
344
{$endif}
 
345
    end;
 
346
  Result:=FRunning;
 
347
end;
 
348
 
 
349
Function TProcess.GetThreadAttributes : TSecurityAttributes;
 
350
 
 
351
Var P : PSecurityAttributes;
 
352
 
 
353
begin
 
354
  IF not Assigned(FThreadAttributes) then
 
355
    begin
 
356
    // Provide empty dummy value;
 
357
    New(p);
 
358
    Fillchar(p^,Sizeof(TSecurityAttributes),0);
 
359
    Result:=p^;
 
360
    end
 
361
  else
 
362
    Result:=FThreadAttributes^;
 
363
end;
 
364
 
 
365
Procedure TProcess.SetProcessAttributes (Value : TSecurityAttributes);
 
366
 
 
367
begin
 
368
  If not Assigned (FProcessAttributes) then
 
369
    New(FProcessAttributes);
 
370
  FPRocessAttributes^:=VAlue;
 
371
end;
 
372
 
 
373
Procedure TProcess.SetThreadAttributes (Value : TSecurityAttributes);
 
374
 
 
375
begin
 
376
  If not Assigned (FThreadAttributes) then
 
377
    New(FThreadAttributes);
 
378
  FThreadAttributes^:=VAlue;
 
379
end;
 
380
 
 
381
Procedure TProcess.CreateStreams;
 
382
 
 
383
begin
 
384
  FreeStreams;
 
385
  CreatePipeStreams (FChildInputSTream,FParentOutPutStream); //,@piInheritablePipe,1024);
 
386
  CreatePipeStreams (FParentInputStream,FChildOutPutStream); //,@piInheritablePipe,1024);
 
387
  if Not (poStdErrToOutPut in FProcessOptions) then
 
388
    CreatePipeStreams (FParentErrorStream,FChildErrorStream) //,@piInheritablePipe,1024)
 
389
  else
 
390
    begin
 
391
    FChildErrorStream:=FChildOutPutStream;
 
392
    FParentErrorStream:=FParentInputStream;
 
393
    end;
 
394
  FStartupInfo.dwFlags:=FStartupInfo.dwFlags or Startf_UseStdHandles;
 
395
  FStartupInfo.hStdInput:=FChildInputStream.Handle;
 
396
  FStartupInfo.hStdOutput:=FChildOutPutStream.Handle;
 
397
  FStartupInfo.hStdError:=FChildErrorStream.Handle;
 
398
end;
 
399
 
 
400
Function TProcess.GetCreationFlags : Cardinal;
 
401
 
 
402
begin
 
403
  Result:=0;
 
404
{$ifndef unix}
 
405
  if poNoConsole in FProcessOptions then
 
406
    Result:=Result or Detached_Process;
 
407
  if poNewConsole in FProcessOptions then
 
408
    Result:=Result or Create_new_console;
 
409
  if poNewProcessGroup in FProcessOptions then
 
410
    Result:=Result or CREATE_NEW_PROCESS_GROUP;
 
411
  If poRunSuspended in FProcessOptions Then
 
412
    Result:=Result or Create_Suspended;
 
413
  if poDebugProcess in FProcessOptions Then
 
414
    Result:=Result or DEBUG_PROCESS;
 
415
  if poDebugOnlyThisProcess in FProcessOptions Then
 
416
    Result:=Result or DEBUG_ONLY_THIS_PROCESS;
 
417
  if poDefaultErrorMode in FProcessOptions Then
 
418
    Result:=Result or CREATE_DEFAULT_ERROR_MODE;
 
419
  result:=result or PriorityConstants[FProcessPriority];
 
420
{$endif}
 
421
end;
 
422
 
 
423
Function TProcess.GetStartupFlags : Cardinal;
 
424
 
 
425
begin
 
426
  Result:=0;
 
427
  if poUsePipes in FProcessOptions then
 
428
     Result:=Result or Startf_UseStdHandles;
 
429
  if suoUseShowWindow in FStartupOptions then
 
430
    Result:=Result or startf_USESHOWWINDOW;
 
431
  if suoUSESIZE in FStartupOptions then
 
432
    Result:=Result or startf_usesize;
 
433
  if suoUsePosition in FStartupOptions then
 
434
    Result:=Result or startf_USEPOSITION;
 
435
  if suoUSECOUNTCHARS in FStartupoptions then
 
436
    Result:=Result or startf_usecountchars;
 
437
  if suoUsefIllAttribute in FStartupOptions then
 
438
    Result:=Result or startf_USEFILLATTRIBUTE;
 
439
end;
 
440
 
 
441
{$ifdef unix}
 
442
Type
 
443
  TPCharArray = Array[Word] of pchar;
 
444
  PPCharArray = ^TPcharArray;
 
445
 
 
446
 
 
447
Function StringsToPCharList(List : TStrings) : PPChar;
 
448
 
 
449
Var
 
450
  I : Integer;
 
451
  S : String;
 
452
 
 
453
begin
 
454
  I:=(List.Count)+1;
 
455
  GetMem(Result,I*sizeOf(PChar));
 
456
  PPCharArray(Result)^[List.Count]:=Nil;
 
457
  For I:=0 to List.Count-1 do
 
458
    begin
 
459
    S:=List[i];
 
460
    Result[i]:=StrNew(PChar(S));
 
461
    end;
 
462
end;
 
463
 
 
464
Procedure FreePCharList(List : PPChar);
 
465
 
 
466
Var
 
467
  I : integer;
 
468
 
 
469
begin
 
470
  I:=0;
 
471
  While List[i]<>Nil do
 
472
    begin
 
473
    StrDispose(List[i]);
 
474
    Inc(I);
 
475
    end;
 
476
  FreeMem(List);
 
477
end;
 
478
 
 
479
{$else}
 
480
 
 
481
Function StringsToPChars(List : TStrings): pointer;
 
482
 
 
483
var
 
484
  EnvBlock: string;
 
485
  I: Integer;
 
486
 
 
487
begin
 
488
  EnvBlock := '';
 
489
  For I:=0 to List.Count-1 do
 
490
    EnvBlock := EnvBlock + List[i] + #0;
 
491
  EnvBlock := EnvBlock + #0;
 
492
  GetMem(Result, Length(EnvBlock));
 
493
  CopyMemory(Result, @EnvBlock[1], Length(EnvBlock));
 
494
end;
 
495
{$endif}
 
496
 
 
497
 
 
498
{$ifdef unix}
 
499
Procedure CommandToList(S : String; List : TStrings);
 
500
 
 
501
  Function GetNextWord : String;
 
502
 
 
503
  Const
 
504
    WhiteSpace = [' ',#8,#10];
 
505
    Literals = ['"',''''];
 
506
 
 
507
  Var
 
508
    Wstart,wend : Integer;
 
509
    InLiteral : Boolean;
 
510
    LastLiteral : char;
 
511
 
 
512
  begin
 
513
    WStart:=1;
 
514
    While (WStart<=Length(S)) and (S[WStart] in WhiteSpace) do
 
515
      Inc(WStart);
 
516
    WEnd:=WStart;
 
517
    InLiteral:=False;
 
518
    LastLiteral:=#0;
 
519
    While (Wend<=Length(S)) and (Not (S[Wend] in WhiteSpace) or InLiteral) do
 
520
      begin
 
521
      if S[Wend] in Literals then
 
522
        If InLiteral then
 
523
          InLiteral:=Not (S[Wend]=LastLiteral)
 
524
        else
 
525
          begin
 
526
          InLiteral:=True;
 
527
          LastLiteral:=S[Wend];
 
528
          end;
 
529
       inc(wend);
 
530
       end;
 
531
     Result:=Copy(S,WStart,WEnd-WStart);
 
532
     Result:=StringReplace(Result,'"','',[rfReplaceAll]);
 
533
     Result:=StringReplace(Result,'''','',[rfReplaceAll]);
 
534
     While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do
 
535
       inc(Wend);
 
536
     Delete(S,1,WEnd-1);
 
537
 
 
538
  end;
 
539
 
 
540
Var
 
541
  W : String;
 
542
 
 
543
begin
 
544
  While Length(S)>0 do
 
545
    begin
 
546
    W:=GetNextWord;
 
547
    If (W<>'') then
 
548
      List.Add(W);
 
549
    end;
 
550
end;
 
551
 
 
552
 
 
553
Function MakeCommand(Var AppName,CommandLine : String;
 
554
                     StartupOptions : TStartUpOptions;
 
555
                     ProcessOptions : TProcessOptions;
 
556
                     StartupInfo : TStartupInfo) : PPchar;
 
557
Const
 
558
  SNoCommandLine = 'Cannot execute empty command-line';
 
559
 
 
560
Var
 
561
  S  : TStringList;
 
562
  G : String;
 
563
 
 
564
begin
 
565
  if (AppName='') then
 
566
    begin
 
567
    If (CommandLine='') then
 
568
      Raise Exception.Create(SNoCommandline)
 
569
    end
 
570
  else
 
571
    begin
 
572
    If (CommandLine='') then
 
573
      CommandLine:=AppName;
 
574
    end;
 
575
  S:=TStringList.Create;
 
576
  try
 
577
    CommandToList(CommandLine,S);
 
578
    if poNewConsole in ProcessOptions then
 
579
      begin
 
580
      S.Insert(0,'-e');
 
581
      If (AppName<>'') then
 
582
        begin
 
583
        S.Insert(0,AppName);
 
584
        S.Insert(0,'-title');
 
585
        end;
 
586
      if suoUseCountChars in StartupOptions then
 
587
        With StartupInfo do
 
588
          begin
 
589
          S.Insert(0,Format('%dx%d',[dwXCountChars,dwYCountChars]));
 
590
          S.Insert(0,'-geometry');
 
591
          end;
 
592
      S.Insert(0,'xterm');
 
593
      end;
 
594
    if (AppName<>'') then
 
595
      begin
 
596
      S.Add(TitleOption);
 
597
      S.Add(AppName);
 
598
      end;
 
599
    With StartupInfo do
 
600
      begin
 
601
      G:='';
 
602
      if (suoUseSize in StartupOptions) then
 
603
        g:=format('%dx%d',[dwXSize,dwYsize]);
 
604
      if (suoUsePosition in StartupOptions) then
 
605
        g:=g+Format('+%d+%d',[dwX,dwY]);
 
606
      if G<>'' then
 
607
        begin
 
608
        S.Add(GeometryOption);
 
609
        S.Add(g);
 
610
        end;
 
611
      end;
 
612
    Result:=StringsToPcharList(S);
 
613
    AppName:=S[0];
 
614
  Finally
 
615
    S.free;
 
616
  end;
 
617
end;
 
618
 
 
619
Function CreateProcess (PName,PCommandLine,PDir : String;
 
620
                        FEnv : PPChar;
 
621
                        StartupOptions : TStartupOptions;
 
622
                        ProcessOptions : TProcessOptions;
 
623
                        const FStartupInfo : TStartupInfo;
 
624
                        Var ProcessInfo : TProcessInformation)  : boolean;
 
625
 
 
626
Var
 
627
  PID : Longint;
 
628
  Argv : PPChar;
 
629
  fd : Integer;
 
630
 
 
631
begin
 
632
  Result:=True;
 
633
  Argv:=MakeCommand(Pname,PCommandLine,StartupOptions,ProcessOptions,FStartupInfo);
 
634
  if (pos('/',PName)<>1) then
 
635
    PName:=FileSearch(Pname,{$ifdef ver1_0}GetEnv{$else}fpgetenv{$endif}('PATH'));
 
636
  Pid:={$ifdef ver1_0}fork;{$else}fpfork;{$endif}
 
637
  if Pid=0 then
 
638
   begin
 
639
   { We're in the child }
 
640
   if (PDir<>'') then
 
641
     ChDir(PDir);
 
642
   if PoUsePipes in ProcessOptions then
 
643
     begin
 
644
     {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(FStartupInfo.hStdInput,0);
 
645
     {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(FStartupInfo.hStdOutput,1);
 
646
     {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(FStartupInfo.hStdError,2);
 
647
     end
 
648
   else if poNoConsole in ProcessOptions then
 
649
     begin
 
650
     fd:=FileOpen('/dev/null',fmOpenReadWrite);
 
651
     {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(fd,0);
 
652
     {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(fd,1);
 
653
     {$ifdef ver1_0}dup2{$else}fpdup2{$endif}(fd,2);
 
654
     end;
 
655
   if (poRunSuspended in ProcessOptions) then
 
656
     sigraise(SIGSTOP);
 
657
   if FEnv<>Nil then
 
658
     {$ifdef ver1_0}execve{$else}fpexecve{$endif}(PChar(PName),Argv,Fenv)
 
659
   else
 
660
     {$ifdef ver1_0}execv{$else}fpexecv{$endif}(Pchar(PName),argv);
 
661
   Halt(127);
 
662
   end
 
663
 else
 
664
   begin
 
665
   FreePcharList(Argv);
 
666
   // Copy process information.
 
667
   ProcessInfo.hProcess:=PID;
 
668
   ProcessInfo.hThread:=PID;
 
669
   ProcessInfo.dwProcessId:=PID;
 
670
   ProcessInfo.dwThreadId:=PID;
 
671
   end;
 
672
end;
 
673
{$endif}
 
674
 
 
675
{$ifdef unix}
 
676
Function GetLastError : Integer;
 
677
 
 
678
begin
 
679
  Result:=-1;
 
680
end;
 
681
{$endif}
 
682
 
 
683
Procedure TProcess.Execute;
 
684
 
 
685
 
 
686
Var
 
687
{$ifndef unix}
 
688
  PName,PDir,PCommandLine : PChar;
 
689
  FEnv: pointer;
 
690
{$else}
 
691
  FEnv : PPChar;
 
692
{$endif}
 
693
  FCreationFlags : Cardinal;
 
694
 
 
695
begin
 
696
  If poUsePipes in FProcessOptions then
 
697
    CreateStreams;
 
698
  FCreationFlags:=GetCreationFlags;
 
699
  FStartupInfo.dwFlags:=GetStartupFlags;
 
700
{$ifndef unix}
 
701
  PName:=Nil;
 
702
  PCommandLine:=Nil;
 
703
  PDir:=Nil;
 
704
  If FApplicationName<>'' then
 
705
    PName:=Pchar(FApplicationName);
 
706
  If FCommandLine<>'' then
 
707
    PCommandLine:=Pchar(FCommandLine);
 
708
  If FCurrentDirectory<>'' then
 
709
    PDir:=Pchar(FCurrentDirectory);
 
710
{$endif}
 
711
  if FEnvironment.Count<>0 then
 
712
{$ifdef unix}
 
713
    FEnv:=StringsToPcharList(FEnvironment)
 
714
{$else}
 
715
    FEnv:=StringsToPChars(FEnvironment)
 
716
{$endif}
 
717
  else
 
718
    FEnv:=Nil;
 
719
  FInheritHandles:=True;
 
720
{$ifdef unix}
 
721
  if Not CreateProcess (FApplicationName,FCommandLine,FCurrentDirectory,FEnv,
 
722
                        FStartupOptions,FProcessOptions,FStartupInfo,
 
723
                        fProcessInformation) then
 
724
{$else}
 
725
  If Not CreateProcess (PName,PCommandLine,FProcessAttributes,FThreadAttributes,
 
726
                 FInheritHandles,FCreationFlags,FEnv,PDir,FStartupInfo,
 
727
                 fProcessInformation) then
 
728
{$endif}
 
729
    Raise Exception.CreateFmt('Failed to execute %s : %d',[FCommandLine,GetLastError]);
 
730
  if POUsePipes in FProcessOptions then
 
731
    begin
 
732
    FileClose(FStartupInfo.hStdInput);
 
733
    FileClose(FStartupInfo.hStdOutput);
 
734
    if Not (poStdErrToOutPut in FProcessOptions) then
 
735
      FileClose(FStartupInfo.hStdError);
 
736
    end;
 
737
{$ifdef unix}
 
738
  Fhandle:=fprocessinformation.hProcess;
 
739
{$endif}
 
740
  FRunning:=True;
 
741
  If FEnv<>Nil then
 
742
{$ifdef unix}
 
743
    FreePCharList(FEnv);
 
744
{$else}
 
745
    FreeMem(FEnv);
 
746
{$endif}
 
747
  if not (csDesigning in ComponentState) and // This would hang the IDE !
 
748
     (poWaitOnExit in FProcessOptions) and
 
749
      not (poRunSuspended in FProcessOptions) then
 
750
    WaitOnExit;
 
751
end;
 
752
 
 
753
Function TProcess.WaitOnExit : Dword;
 
754
 
 
755
begin
 
756
{$ifdef unix}
 
757
  Result:=Dword({$ifdef ver1_0}WaitPid{$else}fpWaitPid{$endif}(Handle,@FExitCode,0));
 
758
  If Result=Handle then
 
759
    FExitCode:=WexitStatus(FExitCode);
 
760
{$else}
 
761
  Result:=WaitForSingleObject (FprocessInformation.hProcess,Infinite);
 
762
  If Result<>Wait_Failed then
 
763
    GetExitStatus;
 
764
{$endif}
 
765
  FRunning:=False;
 
766
end;
 
767
 
 
768
Function TProcess.Suspend : Longint;
 
769
 
 
770
begin
 
771
{$ifdef unix}
 
772
  If {$ifdef ver1_0}kill{$else}fpkill{$endif}(Handle,SIGSTOP)<>0 then
 
773
    Result:=-1
 
774
  else
 
775
    Result:=1;
 
776
{$else}
 
777
  Result:=SuspendThread(ThreadHandle);
 
778
{$endif}
 
779
end;
 
780
 
 
781
Function TProcess.Resume : LongInt;
 
782
 
 
783
begin
 
784
{$ifdef unix}
 
785
  If {$ifdef ver1_0}kill{$else}fpkill{$endif}(Handle,SIGCONT)<>0 then
 
786
    Result:=-1
 
787
  else
 
788
    Result:=0;
 
789
{$else}
 
790
  Result:=ResumeThread(ThreadHandle);
 
791
{$endif}
 
792
end;
 
793
 
 
794
Function TProcess.Terminate(AExitCode : Integer) : Boolean;
 
795
 
 
796
begin
 
797
  Result:=False;
 
798
{$ifdef unix}
 
799
  Result:={$ifdef ver1_0}kill{$else}fpkill{$endif}(Handle,SIGTERM)=0;
 
800
  If Result then
 
801
    begin
 
802
    If Running then
 
803
      Result:={$ifdef ver1_0}kill{$else}fpkill{$endif}(Handle,SIGKILL)=0;
 
804
    end;
 
805
  GetExitStatus;
 
806
{$else}
 
807
  If ExitStatus=Still_active then
 
808
    Result:=TerminateProcess(Handle,AexitCode);
 
809
{$endif}
 
810
end;
 
811
 
 
812
Procedure TProcess.SetFillAttribute (Value : Cardinal);
 
813
 
 
814
begin
 
815
  FStartupInfo.dwFlags:=FStartupInfo.dwFlags or Startf_UseFillAttribute;
 
816
  FStartupInfo.dwFillAttribute:=Value;
 
817
end;
 
818
 
 
819
Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
 
820
 
 
821
{$ifndef unix}
 
822
Const
 
823
  SWC : Array [TShowWindowOptions] of Cardinal =
 
824
             (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show,
 
825
             SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized,
 
826
               SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal);
 
827
{$endif}
 
828
 
 
829
begin
 
830
  FShowWindow:=Value;
 
831
  if Value<>swoNone then
 
832
    FStartupInfo.dwFlags:=FStartupInfo.dwFlags or Startf_UseShowWindow
 
833
  else
 
834
    FStartupInfo.dwFlags:=FStartupInfo.dwFlags and not Startf_UseShowWindow;
 
835
{$ifndef unix}
 
836
  FStartupInfo.wShowWindow:=SWC[Value];
 
837
{$endif}
 
838
end;
 
839
 
 
840
Procedure TProcess.SetWindowColumns (Value : Cardinal);
 
841
 
 
842
begin
 
843
  if Value<>0 then
 
844
    Include(FStartUpOptions,suoUseCountChars);
 
845
  FStartupInfo.dwXCountChars:=Value;
 
846
end;
 
847
 
 
848
 
 
849
Procedure TProcess.SetWindowHeight (Value : Cardinal);
 
850
 
 
851
begin
 
852
  if Value<>0 then
 
853
    include(FStartUpOptions,suoUsePosition);
 
854
  FStartupInfo.dwYsize:=Value;
 
855
end;
 
856
 
 
857
Procedure TProcess.SetWindowLeft (Value : Cardinal);
 
858
 
 
859
begin
 
860
  if Value<>0 then
 
861
    Include(FStartUpOptions,suoUseSize);
 
862
  FStartupInfo.dwx:=Value;
 
863
end;
 
864
 
 
865
Procedure TProcess.SetWindowTop (Value : Cardinal);
 
866
 
 
867
begin
 
868
  if Value<>0 then
 
869
    Include(FStartUpOptions,suoUsePosition);
 
870
  FStartupInfo.dwy:=Value;
 
871
end;
 
872
 
 
873
Procedure TProcess.SetWindowWidth (Value : Cardinal);
 
874
begin
 
875
  If (Value<>0) then
 
876
    Include(FStartUpOptions,suoUseSize);
 
877
  FStartupInfo.dwxsize:=Value;
 
878
end;
 
879
 
162
880
Function TProcess.GetWindowRect : TRect;
163
881
begin
164
882
  With Result do
165
 
    begin
166
 
    Left:=FWindowLeft;
167
 
    Top:=FWindowTop;
168
 
    Right:=FWindowLeft+FWindowWidth;
169
 
    Bottom:=FWindowTop+FWindowRows;
170
 
    end;
 
883
    With FStartupInfo do
 
884
      begin
 
885
      Left:=dwx;
 
886
      Right:=dwx+dwxSize;
 
887
      Top:=dwy;
 
888
      Bottom:=dwy+dwysize;
 
889
      end;
171
890
end;
172
891
 
173
 
Procedure TProcess.SetWindowRect (Value : classes.Trect);
 
892
Procedure TProcess.SetWindowRect (Value : Trect);
174
893
begin
 
894
  Include(FStartupOptions,suouseSize);
 
895
  Include(FStartupOptions,suoUsePosition);
175
896
  With Value do
176
 
    begin
177
 
    FWindowLeft:=Left;
178
 
    FWindowWidth:=Right-Left;
179
 
    FWindowTop:=Top;
180
 
    FWindowRows:=Bottom-top;
181
 
    end;
 
897
    With FStartupInfo do
 
898
      begin
 
899
      dwx:=Left;
 
900
      dwxSize:=Right-Left;
 
901
      dwy:=Top;
 
902
      dwySize:=Bottom-top;
 
903
      end;
 
904
end;
 
905
 
 
906
 
 
907
Procedure TProcess.SetWindowRows (Value : Cardinal);
 
908
 
 
909
begin
 
910
  FStartupInfo.dwFlags:=FStartupInfo.dwFlags or Startf_UseCountChars;
 
911
  FStartupInfo.dwYCountChars:=Value;
 
912
end;
 
913
 
 
914
procedure TProcess.SetApplicationname(const Value: String);
 
915
begin
 
916
  FApplicationname := Value;
 
917
  If (csdesigning in ComponentState) and
 
918
     (FCommandLine='') then
 
919
    FCommandLine:=Value;
 
920
end;
 
921
 
 
922
procedure TProcess.SetProcessOptions(const Value: TProcessOptions);
 
923
begin
 
924
  FProcessOptions := Value;
 
925
  If poNewConsole in FPRocessOptions then
 
926
    Exclude(FProcessoptions,poNoConsole);
 
927
  if poRunSuspended in FProcessOptions then
 
928
    Exclude(FPRocessoptions,poWaitOnExit);
 
929
end;
 
930
 
 
931
procedure TProcess.SetActive(const Value: Boolean);
 
932
begin
 
933
  if (Value<>GetRunning) then
 
934
    If Value then
 
935
      Execute
 
936
    else
 
937
      Terminate(0);
 
938
end;
 
939
 
 
940
procedure TProcess.SetEnvironment(const Value: TStrings);
 
941
begin
 
942
  FEnvironment.Assign(Value);
182
943
end;
183
944
 
184
945
end.
185
 
 
186
946
{
187
947
  $Log: process.pp,v $
188
 
  Revision 1.1  2000/07/13 06:31:31  michael
189
 
  + Initial import
190
 
 
191
 
  Revision 1.7  2000/03/28 06:44:01  michael
192
 
  + TRect should refer to the classes one
193
 
 
194
 
  Revision 1.6  2000/02/15 22:03:38  sg
195
 
  * Inserted wrong copyright notice ;)  Fixed.
196
 
 
197
 
  Revision 1.5  2000/02/15 21:57:51  sg
198
 
  * Added copyright notice and CVS log tags where necessary
 
948
  Revision 1.19  2004/02/03 08:12:22  michael
 
949
  + Patch from Vincent Snijders to fix passing environment vars in win32
 
950
 
 
951
  Revision 1.18  2003/10/30 20:34:47  florian
 
952
    * fixed inherited destroy; call of tprocess
 
953
 
 
954
  Revision 1.17  2003/09/20 12:38:29  marco
 
955
   * FCL now compiles for FreeBSD with new 1.1. Now Linux.
 
956
 
 
957
  Revision 1.16  2003/08/12 13:49:42  michael
 
958
  + Freed streams were not closed correctly
 
959
 
 
960
  Revision 1.15  2003/05/08 20:04:16  armin
 
961
  * Dont close FStartupInfo.hStdError if options include poStdErrToOutPut
 
962
 
 
963
  Revision 1.14  2003/04/27 21:21:42  sg
 
964
  * Added typecast to prevent range check error in TProcess.WaitOnExit
 
965
 
 
966
  Revision 1.13  2002/09/07 15:15:25  peter
 
967
    * old logs removed and tabs fixed
199
968
 
200
969
}