1 {
2 /***************************************************************************
3 lazarusmanager.pas
4 --------------------
5 Class to manage starting and restarting of lazarus
6
7 ***************************************************************************/
8
9 ***************************************************************************
10 * *
11 * This source is free software; you can redistribute it and/or modify *
12 * it under the terms of the GNU General Public License as published by *
13 * the Free Software Foundation; either version 2 of the License, or *
14 * (at your option) any later version. *
15 * *
16 * This code is distributed in the hope that it will be useful, but *
17 * WITHOUT ANY WARRANTY; without even the implied warranty of *
18 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
19 * General Public License for more details. *
20 * *
21 * A copy of the GNU General Public License is available on the World *
22 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
23 * obtain it by writing to the Free Software Foundation, *
24 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
25 * *
26 ***************************************************************************
27 }
28 (*
29 Abstract:
30 This is the worker unit of the 'startlazarus' application.
31
32 It waits for running lazarus, if its pid was passed as command line
33 parameter.
34 It searches the new lazarus executable.
35 1. open the build lazarus options and look for a custom target directory
36 2. look in the directory of startlazarus (the lazarus main directory)
37 and in $(ConfigDir)/bin/ and use the newest lazarus executable.
38 On systems which lock executables on run it renames the
39 lazarus to lazarus.old and lazarus.new to lazarus.
40 Then it starts lazarus and waits until it is finished. If lazarus gives a
41 special exit code (ExitCodeRestartLazarus), it goes to step 1.
42 Any other exit code, also stops startlazarus.
43
44 Why that?
45 - To install a package into the IDE statically, it must be relinked.
46 This creates a new lazarus[.exe] executable. With the help of startlazarus
47 the IDE can then automatically restart itself.
48 - What happens when a new executable is created:
49 - If the installation directory is writeable to the user, the current
50 "lazarus.exe" (which is or should be the file from wich the running IDE
51 was started) can not be deleted while the IDE is running (Windows locks
52 the file).
53 It is renamed to lazarus.old instead, which if exists is overwritten.
54 If lazarus.old is locked (due to a previous rebuild/rename without
55 restarting the IDE), then it is renamed to lazarus.old2.
56 In this case a restart could be done without the use of startlazarus.
57 Note that before 1.0 the IDE was compiled into lazarus.exe.new, and
58 startlazarus did the rename.
59 - If the installation directory is not writeable by the user, then the new
60 lazarus.exe is created in the primary config path, which is usually in
61 the users home directory.
62 The IDE will not update any shortcuts/links, such as startmenu entries or
63 desktop icons. The IDE may not even have a complete list of those. They
64 should instead point to startlazarus, which is kept in a fixed location.
65 startlazarus then locates the correct lazarus.exe
66 - Building can result in a broken IDE. Therefore backups are created.
67 - Copying is slow (especially the huge IDE). So only 'rename' is used for
68 backup.
69 - The IDE calls 'make' to rebuild itself. This deletes the old lazarus
70 executable on some systems. So, the backup must be made before building
71 for these systems.
72 - When the original directory can't be used (readonly), the build directory
73 is <primary config path>/bin/, which results in ~/.lazarus/bin/ on unix
74 style systems like linux, bsd, macosx and {AppData}\Lazarus\bin on windows
75 (this is still a todo on windows).
76 - For debugging purposes you can work without startlazarus.
77 - The user can define the Target Directory.
78 - The IDE can be cross compiled. The resulting executable will be created
79 in <primary config path>/bin/<TargetOS>
80 *)
81 unit LazarusManager;
82
83 {$mode objfpc}{$H+}
84
85 interface
86
87 uses
88 {$IFdef MSWindows}
89 Windows,
90 {$ENDIF}
91 {$IFDEF unix}
92 BaseUnix,
93 {$ENDIF}
94 Classes, SysUtils, Process,
95 // LCL
96 Forms, Controls, Dialogs,
97 // LazUtils
98 UTF8Process, FileUtil, LazFileUtils, LazUtilities, LazUTF8,
99 // CodeTools
100 FileProcs,
101 // IdeIntf
102 BaseIDEIntf,
103 // IDE
104 IDECmdLine, LazConf, Splash, IDEInstances;
105
106 type
107
108 { TLazarusProcess }
109
110 TLazarusProcess = class
111 private
112 FOnStart: TNotifyEvent;
113 FProcess: TProcessUTF8;
114 FWantsRestart: boolean;
115 public
116 constructor Create;
117 destructor Destroy; override;
118 procedure Execute;
119 procedure WaitOnExit;
120 property WantsRestart: boolean read FWantsRestart;
121 property OnStart: TNotifyEvent read FOnStart write FOnStart;
122 property Process: TProcessUTF8 read FProcess;
123 end;
124
125 type
126
127 { TLazarusManager }
128
129 TLazarusManager = class(TComponent)
130 private
131 FLazarusProcess: TLazarusProcess;
132 FLazarusPath: string;
133 FLazarusPID: Integer;
134 FCmdLineParams: TStrings;
135 FCmdLineFiles: string;
136 FShowSplashOption: boolean;
RenameLazarusExecutablenull137 function RenameLazarusExecutable(const Directory: string): TModalResult;
138 procedure LazarusProcessStart(Sender: TObject);
139 public
140 destructor Destroy; override;
141 procedure Initialize;
142 procedure WaitForLazarus;
143 procedure Run;
144 procedure ShowSplash;
145 property ShowSplashOption: boolean read FShowSplashOption write FShowSplashOption;
146 end;
147
148 implementation
149
150 destructor TLazarusManager.Destroy;
151 begin
152 FreeAndNil(FCmdLineParams);
153 inherited Destroy;
154 end;
155
TLazarusManager.RenameLazarusExecutablenull156 function TLazarusManager.RenameLazarusExecutable(const Directory: string
157 ): TModalResult;
158 var
159 NewFilename: String;
160 BackupFilename: String;
161 CurFilename: String;
162 begin
163 NewFilename:=AppendPathDelim(Directory)+'lazarus.new'+GetExeExt;
164 BackupFilename:=AppendPathDelim(Directory)+'lazarus.old'+GetExeExt;
165 CurFilename:=AppendPathDelim(Directory)+'lazarus'+GetExeExt;
166 if FileExistsUTF8(NewFileName) then
167 begin
168 if FileExistsUTF8(CurFilename) then
169 begin
170 if FileExistsUTF8(BackupFileName) then
171 if not DeleteFileUTF8(BackupFileName) then begin
172 MessageDlg (format('Can''t delete "%s"'+LineEnding+'%s',
173 [BackupFileName, SysErrorMessageUTF8(GetLastOSError)]),
174 mtError, [mbOK], 0);
175 Result := mrAbort;
176 exit;
177 end;
178 if not RenameFileUTF8(CurFilename, BackupFileName) then begin
179 MessageDlg (format('Can''t rename "%s" to "%s"'+LineEnding+'%s',
180 [CurFilename, BackupFileName, SysErrorMessageUTF8(GetLastOSError)]),
181 mtError, [mbOK], 0);
182 Result := mrAbort;
183 exit;
184 end;
185 InvalidateFileStateCache;
186 end;
187 if not RenameFileUTF8(NewFileName, CurFilename) then begin
188 MessageDlg (format('Can''t rename "%s" to "%s"'+LineEnding+'%s',
189 [NewFileName, CurFilename, SysErrorMessageUTF8(GetLastOSError)]),
190 mtError, [mbOK], 0);
191 Result := mrAbort;
192 exit;
193 end;
194 InvalidateFileStateCache;
195 end;
196 Result:=mrOk;
197 end;
198
199 procedure TLazarusManager.LazarusProcessStart(Sender: TObject);
200 begin
201 if SplashForm<>nil then SplashForm.Hide;
202 FreeThenNil(SplashForm);
203 Application.ProcessMessages;
204 end;
205
206 procedure TLazarusManager.WaitForLazarus;
207 procedure WaitForPid(PID: integer);
208 {$IFDEF WINDOWS}
209 var
210 ProcessHandle: THandle;
211 begin
212 ProcessHandle := OpenProcess(SYNCHRONIZE, false, PID);
213 if ProcessHandle<>0 then begin
214 WaitForSingleObject(ProcessHandle, INFINITE);
215 CloseHandle(ProcessHandle);
216 end;
217 end;
218 {$ELSE}
219 {$IFDEF UNIX}
220 var
221 Result: integer;
222 begin
223 repeat
224 Sleep(100);
225 Result := fpKill(PID, 0);
226 until Result<>0;
227 end;
228 {$ELSE}
229 begin
230 DebugLn('WaitForPid not implemented for this OS. We just wait 5 seconds');
231 Sleep(5000);
232 end;
233 {$ENDIF}
234 {$ENDIF}
235 begin
236 if FLazarusPID<>0 then
237 WaitForPID(FLazarusPID);
238 end;
239
240 procedure TLazarusManager.Initialize;
241 var
242 CmdLineFiles: TStrings;
243 i: integer;
244 PCP: String;
245 begin
246 FShowSplashOption:=true;
247 SplashForm := nil;
248
249 // get command line parameters
250 FCmdLineParams := TStringListUTF8Fast.Create;
251 ParseCommandLine(FCmdLineParams, FLazarusPID, FShowSplashOption);
252 if FShowSplashOption then
253 ShowSplash;
254
255 // we already handled IDEInstances, ignore it in lazarus EXE
256 if (FCmdLineParams.IndexOf(ForceNewInstanceOpt) = -1) then
257 FCmdLineParams.Add(ForceNewInstanceOpt);
258
259 // set primary config path
260 PCP:=ExtractPrimaryConfigPath(FCmdLineParams);
261 if PCP<>'' then
262 SetPrimaryConfigPath(PCP);
263
264 // get command line files
265 CmdLineFiles := LazIDEInstances.FilesToOpen;
266 if CmdLineFiles<>nil then
267 begin
268 for i := 0 to CmdLineFiles.Count-1 do
269 if pos(' ',CmdLineFiles[i])>0 then
270 CmdLineFiles[i] := '"' + CmdLineFiles[i] + '"';
271 CmdLineFiles.Delimiter:=' ';
272 FCmdLineFiles:=CmdLineFiles.DelimitedText;
273 end;
274 end;
275
276 procedure TLazarusManager.Run;
277
278 procedure AddExpandedParam(Params: TStringList; Param: string);
279 begin
280 // skip startlazarus params
281 if LeftStr(Param,length(StartLazarusPidOpt))=StartLazarusPidOpt then
282 exit;
283 // expand filenames and append
284 Params.Add(ExpandParamFile(Param));
285 end;
286
287 var
288 Restart: boolean;
289 DefaultDir: String;
290 CustomDir: String;
291 DefaultExe: String;
292 CustomExe: String;
293 MsgResult: TModalResult;
294 StartPath: String;
295 EnvOverrides: TStringList;
296 Params: TStringList;
297 i: Integer;
298 begin
299 try
300 StartPath:=ExpandFileNameUTF8(ParamStrUTF8(0));
301 if FileIsSymlink(StartPath) then
302 StartPath:=GetPhysicalFilename(StartPath,pfeException);
303 DefaultDir:=ExtractFilePath(StartPath);
304 if DirectoryExistsUTF8(DefaultDir) then
305 DefaultDir:=GetPhysicalFilename(DefaultDir,pfeException);
306 except
307 on E: Exception do begin
308 MessageDlg ('Error',E.Message,mtError,[mbCancel],0);
309 exit;
310 end;
311 end;
312 DefaultDir:=AppendPathDelim(DefaultDir);
313 CustomDir:=AppendPathDelim(GetPrimaryConfigPath) + 'bin' + PathDelim;
314
315 repeat
316 Restart := false;
317 if FShowSplashOption then
318 ShowSplash;
319 { There are four places where the newest lazarus exe can be:
320 1. in the same directory as the startlazarus exe
321 1.1 as lazarus.new(.exe) (if the executable was write locked (windows))
322 1.2 as lazarus(.exe) (if the executable was writable (non windows))
323 2. in the config directory (e.g. ~/.lazarus/bin/)
324 2.1 as lazarus.new(.exe) (if the executable was write locked (windows))
325 2.2 as lazarus(.exe) (if the executable was writable (non windows))
326 }
327 if (RenameLazarusExecutable(DefaultDir)=mrOK)
328 and (RenameLazarusExecutable(CustomDir)=mrOK) then
329 begin
330 DefaultExe:=DefaultDir+'lazarus'+GetExeExt;
331 CustomExe:=CustomDir+'lazarus'+GetExeExt;
332 if FileExistsUTF8(DefaultExe) then begin
333 if FileExistsUTF8(CustomExe) then begin
334 // both exist
335 if (FileAgeUTF8(CustomExe)>=FileAgeUTF8(DefaultExe)) then begin
336 // the custom exe is newer or equal => use custom
337 // Equal files ages catches the case where the two names refer to the same file on disk
338 FLazarusPath:=CustomExe;
339 end else begin
340 // the custom exe is older => let user choose
341 MsgResult:=QuestionDlg{NOTE: Do not use IDEQuestionDialog!!!}(
342 'Multiple lazarus found',
343 'Which Lazarus should be started?'+LineEnding
344 +LineEnding
345 +'The system default executable'+LineEnding
346 +DefaultExe+LineEnding
347 +'(date: '+DateTimeToStr(FileDateToDateTimeDef(FileAgeUTF8(DefaultExe)))+')'+LineEnding
348 +LineEnding
349 +'Or your custom executable'+LineEnding
350 +CustomExe+LineEnding
351 +'(date: '+DateTimeToStr(FileDateToDateTimeDef(FileAgeUTF8(CustomExe)))+')'+LineEnding
352 ,mtConfirmation,
353 [mrYes,'Start system default',mrNo,'Start my custom',mrAbort],'');
354 case MsgResult of
355 mrYes: FLazarusPath:=DefaultExe;
356 mrNo: FLazarusPath:=CustomExe;
357 else break;
358 end;
359 end;
360 end else begin
361 // only the default exists => use default
362 FLazarusPath:=DefaultExe;
363 end;
364 end else begin
365 if FileExistsUTF8(CustomExe) then begin
366 // only the custom exists => warn user
367 MessageDlg ('System default is missing',
368 'The system default lazarus executable "'+DefaultExe+'" is missing, but your custom'
369 +'executable is still there:'+LineEnding
370 +CustomExe+LineEnding
371 +'This will be started ...'
372 ,mtInformation,[mbOk],0);
373 FLazarusPath:=CustomExe;
374 end else begin
375 // no exe exists
376 MessageDlg ('File not found','Can''t find the lazarus executable '+DefaultExe,
377 mtError,[mbAbort],0);
378 break;
379 end;
380 end;
381 {$IFDEF darwin}
382 if DirectoryExistsUTF8(FLazarusPath+'.app') then begin
383 // start the bundle instead
384 FLazarusPath:= FLazarusPath+'.app';// /Contents/MacOS/'+ExtractFileName(FLazarusPath);
385 end;
386 {$ENDIF}
387
388 DebugLn(['Info: (startlazarus) [TLazarusManager.Run] starting ',FLazarusPath,' ...']);
389 EnvOverrides:=TStringList.Create;
390 Params:=TStringList.Create;
391 FLazarusProcess := TLazarusProcess.Create;
392 try
393 {$IFDEF Linux}
394 EnvOverrides.Values['LIBOVERLAY_SCROLLBAR']:='0';
395 {$ENDIF}
396 FLazarusProcess.Process.Executable:=fLazarusPath;
397 if (EnvOverrides<>nil) and (EnvOverrides.Count>0) then
398 AssignEnvironmentTo(FLazarusProcess.Process.Environment,EnvOverrides);
399 {$IFDEF darwin}
400 // GUI bundles must be opened by "open".
401 // "open" runs a bundle, but doesn't wait for it to finish execution.
402 // startlazarus will exit and lazarus has to start a new startlazarus
403 // when it needs a restart
404 FLazarusProcess.Process.Executable:='/usr/bin/open';
405 Params.Add('-a');
406 Params.Add(FLazarusPath);
407 Params.Add('--args');
408 {$ELSE}
409 // tell lazarus, startlazarus is waiting for its exitcode
410 // When the special 99 (ExitCodeRestartLazarus) code is received,
411 // start a new lazars
412 Params.Add(StartedByStartLazarusOpt);
413 {$ENDIF}
414 Params.Add(NoSplashScreenOptLong);
415 for i:=0 to FCmdLineParams.Count-1 do
416 AddExpandedParam(Params,FCmdLineParams[i]);
417 FLazarusProcess.Process.Parameters.AddStrings(Params);
418 finally
419 Params.Free;
420 EnvOverrides.Free;
421 end;
422 // clear the command line files, so that they are passed only once.
423 FCmdLineFiles:='';
424 FLazarusProcess.OnStart := @LazarusProcessStart;
425 DebugLn(['Info: (startlazarus) [TLazarusManager.Run] exe',FLazarusProcess.Process.Executable,' Params=[',FLazarusProcess.Process.Parameters.Text,']']);
426 FLazarusProcess.Execute;
427 {$IFDEF darwin}
428 Restart:=false;
429 {$ELSE}
430 FLazarusProcess.WaitOnExit;
431 Restart := FLazarusProcess.WantsRestart;
432 {$ENDIF}
433 FreeAndNil(FLazarusProcess);
434 end;
435 until not Restart;
436 Application.Terminate;
437 end;
438
439 procedure TLazarusManager.ShowSplash;
440 begin
441 if SplashForm=nil then SplashForm := TSplashForm.Create(Self);
442 with SplashForm do
443 begin
444 Show;
445 Update;
446 end;
447 Application.ProcessMessages; // process splash paint message
448 end;
449
450 { TLazarusProcess }
451
452 constructor TLazarusProcess.Create;
453 begin
454 FProcess := TProcessUTF8.Create(nil);
455 FProcess.InheritHandles := false;
456 FProcess.Options := [];
457 FProcess.ShowWindow := swoShow;
458 end;
459
460 destructor TLazarusProcess.Destroy;
461 begin
462 FreeAndNil(FProcess);
463 inherited Destroy;
464 end;
465
466 procedure TLazarusProcess.Execute;
467 begin
468 FProcess.Execute;
469 Sleep(2000);
470 if Assigned(FOnStart) then
471 FOnStart(Self);
472 end;
473
474 procedure TLazarusProcess.WaitOnExit;
475 begin
476 FProcess.WaitOnExit;
477 FWantsRestart := FProcess.ExitStatus=ExitCodeRestartLazarus;
478 end;
479
480 end.
481
482