1 {
2 /***************************************************************************
3 ideinstances.pas
4 ----------------
5
6 ***************************************************************************/
7
8 ***************************************************************************
9 * *
10 * This source is free software; you can redistribute it and/or modify *
11 * it under the terms of the GNU General Public License as published by *
12 * the Free Software Foundation; either version 2 of the License, or *
13 * (at your option) any later version. *
14 * *
15 * This code is distributed in the hope that it will be useful, but *
16 * WITHOUT ANY WARRANTY; without even the implied warranty of *
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
18 * General Public License for more details. *
19 * *
20 * A copy of the GNU General Public License is available on the World *
21 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
22 * obtain it by writing to the Free Software Foundation, *
23 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
24 * *
25 ***************************************************************************
26
27 Author: Ondrej Pokorny
28
29 Abstract:
30 This unit handles one/multiple Lazarus IDE instances.
31
32 }
33 unit IDEInstances;
34
35 {$mode objfpc}{$H+}
36
37 interface
38
39 uses
40 Classes, sysutils, crc, Process,
41 {$IF (FPC_FULLVERSION >= 30101)}
42 AdvancedIPC,
43 {$ELSE}
44 LazAdvancedIPC,
45 {$ENDIF}
46 Interfaces, Controls, Forms, Dialogs, ExtCtrls, LCLProc,
47 LCLIntf, LCLType, LazFileUtils, LazUTF8, laz2_XMLRead, laz2_XMLWrite,
48 Laz2_DOM, FileUtil, UTF8Process,
49 LazarusIDEStrConsts, IDECmdLine, LazConf;
50
51 type
52 TStartNewInstanceResult = (ofrStartNewInstance, ofrDoNotStart, ofrModalError,
53 ofrForceSingleInstanceModalError, ofrNotResponding);
54 TStartNewInstanceEvent = procedure(const aFiles: TStrings;
55 var outResult: TStartNewInstanceResult; var outSourceWindowHandle: HWND) of object;
56 TGetCurrentProjectEvent = procedure(var outProjectFileName: string) of object;
57
58 TMessageParam = record
59 Name: string;
60 Value: string;
61 end;
62 TMessageParams = array of TMessageParam;
63
64 TUniqueServer = class(TIPCServer)
65 public
66 procedure StartUnique(const aServerPrefix: string);
67 end;
68
69 TMainServer = class(TUniqueServer)
70 private
71 FStartNewInstanceEvent: TStartNewInstanceEvent;
72 FGetCurrentProjectEvent: TGetCurrentProjectEvent;
73 FTimer: TTimer;
74 FMsgStream: TMemoryStream;
75
76 procedure DoStartNewInstance(const aMsgID: Integer; const aInParams: TMessageParams);
77 procedure DoGetCurrentProject(const aMsgID: Integer; const {%H-}aInParams: TMessageParams);
78
79 procedure SimpleResponse(const aResponseToMsgID: Integer;
80 const aResponseType: string; const aParams: array of TMessageParam);
81
82 procedure DoCheckMessages;
83 procedure CheckMessagesOnTimer(Sender: TObject);
84
85 procedure StartListening(const aStartNewInstanceEvent: TStartNewInstanceEvent;
86 const aGetCurrentProjectEvent: TGetCurrentProjectEvent);
87 procedure StopListening;
88
89 public
90 constructor Create(aOwner: TComponent); override;
91 destructor Destroy; override;
92 end;
93
94 TResponseClient = class(TIPCClient)
95 public
GetCurrentProjectFileNamenull96 function GetCurrentProjectFileName: string;
AllowStartNewInstancenull97 function AllowStartNewInstance(
98 const aFiles: TStrings; var outModalErrorMessage,
99 outModalErrorForceUniqueMessage, outNotRespondingErrorMessage: string;
100 var outHandleBringToFront: HWND): TStartNewInstanceResult;
101 end;
102
103 { TIDEInstances }
104
105 TIDEInstances = class(TComponent)
106 private
107 FMainServer: TMainServer;//running IDE
108 FStartIDE: Boolean;// = True;
109 FForceNewInstance: Boolean;
110 FFilesToOpen: TStrings;
111
112 class procedure AddFilesToParams(const aFiles: TStrings;
113 var ioParams: TMessageParams); static;
114 class procedure AddFilesFromParams(const aParams: TMessageParams;
115 const aFiles: TStrings); static;
116 class procedure BuildMessage(const aMessageType: string;
117 const aParams: array of TMessageParam; const aStream: TStream); static;
MessageParamnull118 class function MessageParam(const aName, aValue: string): TMessageParam; static;
ParseMessagenull119 class function ParseMessage(const aStream: TStream; out outMessageType: string;
120 out outParams: TMessageParams): Boolean; static;
GetMessageParamnull121 class function GetMessageParam(const aParams: array of TMessageParam;
122 const aParamName: string): string; static;
123
CheckParamsForForceNewInstanceOptnull124 function CheckParamsForForceNewInstanceOpt: Boolean;
125
126 procedure CollectFiles(out
127 outFilesWereSentToCollectingServer: Boolean);
128
AllowStartNewInstancenull129 function AllowStartNewInstance(const aFiles: TStrings;
130 var outModalErrorMessage, outModalErrorForceUniqueMessage, outNotRespondingErrorMessage: string;
131 var outHandleBringToFront: HWND): TStartNewInstanceResult;
132
StartUserBuiltIDEnull133 function StartUserBuiltIDE: TStartNewInstanceResult;
134
135 procedure InitIDEInstances;
136 public
137 constructor Create(aOwner: TComponent); override;
138 destructor Destroy; override;
139 public
140 procedure PerformCheck;//call PerformCheck after Application.Initialize - it can open dialogs!
141
142 procedure StartServer;
143 procedure StopServer;
144 procedure StartListening(const aStartNewInstanceEvent: TStartNewInstanceEvent;
145 const aGetCurrentProjectEvent: TGetCurrentProjectEvent);
146 procedure StopListening;
147
StartIDEnull148 function StartIDE: Boolean;//can the IDE be started?
ProjectIsOpenInAnotherInstancenull149 function ProjectIsOpenInAnotherInstance(aProjectFileName: string): Boolean;
FilesToOpennull150 function FilesToOpen: TStrings;
151 end;
152
LazIDEInstancesnull153 function LazIDEInstances: TIDEInstances;
154
155 implementation
156
157 const
158 SERVERNAME_COLLECT = 'LazarusCollect';
159 MESSAGETYPE_XML = 2;
160 ELEMENT_ROOT = 'ideinstances';
161 ATTR_VALUE = 'value';
162 ATTR_MESSAGE_TYPE = 'msgtype';
163 MESSAGE_STARTNEWINSTANCE = 'startnewinstance';
164 RESPONSE_OPENFILES = 'openfilesResponse';
165 TIMEOUT_OPENFILES = 1000;
166 MESSAGE_COLLECTFILES = 'collectfiles';
167 TIMEOUT_COLLECTFILES = 100;
168 PARAM_FILE = 'file';
169 PARAM_RESULT = 'result';
170 PARAM_HANDLEBRINGTOFRONT = 'handlebringtofront';
171 PARAM_MODALERRORMESSAGE = 'modalerrormessage';
172 PARAM_FORCEUNIQUEMODALERRORMESSAGE = 'forceuniquemodalerrormessage';
173 PARAM_NOTRESPONDINGERRORMESSAGE = 'notrespondingerrormessage';
174 MESSAGE_GETOPENEDPROJECT = 'getopenedproject';
175 RESPONSE_GETOPENEDPROJECT = 'getopenedprojectResponse';
176 TIMEOUT_GETOPENEDPROJECT = 100;
177 var
178 FLazIDEInstances: TIDEInstances;
179 FServerPrefix: string;
180
LazIDEInstancesnull181 function LazIDEInstances: TIDEInstances;
182 begin
183 Result := FLazIDEInstances;
184 end;
185
LazServerPrefixnull186 function LazServerPrefix: string;
187 // allow for multiple users on lazarus host system - encode to prevent illegal chars
188 begin
189 if FServerPrefix = '' then
190 begin
191 // Calculate the user specific instance prefix only once.
192 FServerPrefix := GetEnvironmentVariable('USER'); // current user
193 // encode to cover illegal chars ('-' etc)
194 FServerPrefix := IntToStr( crc32(0, pbyte(FServerPrefix), Length(FServerPrefix)) )
195 + '_LazarusMain';
196 end;
197 Result := FServerPrefix;
198 end;
199
200
201 { TIDEInstances }
202
TIDEInstances.MessageParamnull203 class function TIDEInstances.MessageParam(const aName, aValue: string): TMessageParam;
204 begin
205 Result.Name := aName;
206 Result.Value := aValue;
207 end;
208
TIDEInstances.StartIDEnull209 function TIDEInstances.StartIDE: Boolean;
210 begin
211 Result := FStartIDE;
212 end;
213
TIDEInstances.ProjectIsOpenInAnotherInstancenull214 function TIDEInstances.ProjectIsOpenInAnotherInstance(aProjectFileName: string
215 ): Boolean;
216 var
217 xStartClient: TResponseClient;
218 I: Integer;
219 xServerIDs: TStringList;
220 xProjFileName: string;
221 begin
222 aProjectFileName := ExtractFilePath(aProjectFileName)+ExtractFileNameOnly(aProjectFileName);
223
224 xStartClient := nil;
225 xServerIDs := nil;
226 try
227 xStartClient := TResponseClient.Create(nil);
228 xServerIDs := TStringList.Create;
229 xStartClient.FindRunningServers(LazServerPrefix, xServerIDs);
230
231 for I := 0 to xServerIDs.Count-1 do
232 begin
233 if FMainServer.ServerID = xServerIDs[I] then
234 continue; // ignore current instance
235 xStartClient.ServerID := xServerIDs[I];
236 xProjFileName := xStartClient.GetCurrentProjectFileName;
237 if (xProjFileName='') then
238 continue;
239 xProjFileName := ExtractFilePath(xProjFileName)+ExtractFileNameOnly(xProjFileName);
240 if CompareFilenames(xProjFileName, aProjectFileName)=0 then
241 Exit(True);
242 end;
243 finally
244 xStartClient.Free;
245 xServerIDs.Free;
246 end;
247 Result := False;
248 end;
249
TIDEInstances.FilesToOpennull250 function TIDEInstances.FilesToOpen: TStrings;
251 begin
252 if not Assigned(FFilesToOpen) then
253 FFilesToOpen := TStringList.Create;
254 Result := FFilesToOpen;
255 end;
256
257 procedure TIDEInstances.StartListening(
258 const aStartNewInstanceEvent: TStartNewInstanceEvent;
259 const aGetCurrentProjectEvent: TGetCurrentProjectEvent);
260 begin
261 Assert(Assigned(FMainServer));
262
263 FMainServer.StartListening(aStartNewInstanceEvent, aGetCurrentProjectEvent);
264 end;
265
266 procedure TIDEInstances.StartServer;
267 begin
268 Assert(FMainServer = nil);
269
270 FMainServer := TMainServer.Create(Self);
271 FMainServer.StartUnique(LazServerPrefix);
272 end;
273
274 procedure TIDEInstances.StopListening;
275 begin
276 FMainServer.StopListening;
277 end;
278
279 procedure TIDEInstances.StopServer;
280 begin
281 FreeAndNil(FMainServer);
282 end;
283
284 class procedure TIDEInstances.AddFilesFromParams(const aParams: TMessageParams;
285 const aFiles: TStrings);
286 var
287 I: Integer;
288 begin
289 //do not clear aFiles
290 for I := Low(aParams) to High(aParams) do
291 if aParams[I].Name = PARAM_FILE then
292 aFiles.Add(aParams[I].Value);
293 end;
294
295 class procedure TIDEInstances.AddFilesToParams(const aFiles: TStrings;
296 var ioParams: TMessageParams);
297 var
298 xStartIndex: Integer;
299 I: Integer;
300 begin
301 xStartIndex := Length(ioParams);
302 SetLength(ioParams, xStartIndex+aFiles.Count);
303 for I := 0 to aFiles.Count-1 do
304 ioParams[xStartIndex+I] := MessageParam(PARAM_FILE, aFiles[I]);
305 end;
306
TIDEInstances.GetMessageParamnull307 class function TIDEInstances.GetMessageParam(
308 const aParams: array of TMessageParam; const aParamName: string): string;
309 var
310 I: Integer;
311 begin
312 for I := Low(aParams) to High(aParams) do
313 if aParams[I].Name = aParamName then
314 Exit(aParams[I].Value);
315
316 Result := '';//not found
317 end;
318
319 class procedure TIDEInstances.BuildMessage(const aMessageType: string;
320 const aParams: array of TMessageParam; const aStream: TStream);
321 var
322 xDOM: TXMLDocument;
323 xRoot: TDOMElement;
324 xParam: TDOMElement;
325 I: Integer;
326 begin
327 xDOM := TXMLDocument.Create;
328 try
329 xRoot := xDOM.CreateElement(ELEMENT_ROOT);
330 xRoot.AttribStrings[ATTR_MESSAGE_TYPE] := aMessageType;
331 xDOM.AppendChild(xRoot);
332
333 for I := Low(aParams) to High(aParams) do
334 begin
335 xParam := xDOM.CreateElement(aParams[I].Name);
336 xRoot.AppendChild(xParam);
337 xParam.AttribStrings[ATTR_VALUE] := aParams[I].Value;
338 end;
339
340 WriteXMLFile(xDOM, aStream);
341 finally
342 xDOM.Free;
343 end;
344 end;
345
TIDEInstances.ParseMessagenull346 class function TIDEInstances.ParseMessage(const aStream: TStream; out
347 outMessageType: string; out outParams: TMessageParams): Boolean;
348 var
349 xDOM: TXMLDocument;
350 xChildList: TDOMNodeList;
351 I, J: Integer;
352 begin
353 Result := False;
354
355 outMessageType := '';
356 SetLength(outParams{%H-}, 0);
357 try
358 ReadXMLFile(xDOM, aStream, []);
359 except
360 on EXMLReadError do
361 Exit;//eat XML exceptions
362 end;
363 try
364 if (xDOM = nil) or (xDOM.DocumentElement = nil) or (xDOM.DocumentElement.NodeName <> ELEMENT_ROOT) then
365 Exit;
366
367 outMessageType := xDOM.DocumentElement.AttribStrings[ATTR_MESSAGE_TYPE];
368
369 xChildList := xDOM.DocumentElement.ChildNodes;
370 SetLength(outParams, xChildList.Count);
371 J := 0;
372 for I := 0 to xChildList.Count-1 do
373 if xChildList[I] is TDOMElement then
374 begin
375 outParams[J].Name := xChildList[I].NodeName;
376 outParams[J].Value := TDOMElement(xChildList[I]).AttribStrings[ATTR_VALUE];
377 Inc(J);
378 end;
379 SetLength(outParams, J);
380 Result := True;
381 finally
382 xDOM.Free;
383 end;
384 end;
385
TIDEInstances.AllowStartNewInstancenull386 function TIDEInstances.AllowStartNewInstance(const aFiles: TStrings;
387 var outModalErrorMessage, outModalErrorForceUniqueMessage,
388 outNotRespondingErrorMessage: string; var outHandleBringToFront: HWND
389 ): TStartNewInstanceResult;
390 var
391 xStartClient: TResponseClient;
392 I: Integer;
393 xServerIDs: TStringListUTF8Fast;
394 begin
395 Result := ofrStartNewInstance;
396 xStartClient := TResponseClient.Create(nil);
397 xServerIDs := TStringListUTF8Fast.Create;
398 try //check for multiple instances
399 xStartClient.FindRunningServers(LazServerPrefix, xServerIDs);
400 xServerIDs.Sort;
401
402 for I := xServerIDs.Count-1 downto 0 do//last started is first to choose
403 begin
404 xStartClient.ServerID := xServerIDs[I];
405 if xStartClient.ServerRunning then
406 begin
407 Result := xStartClient.AllowStartNewInstance(aFiles, outModalErrorMessage,
408 outModalErrorForceUniqueMessage, outNotRespondingErrorMessage, outHandleBringToFront);
409 if not(Result in [ofrModalError, ofrForceSingleInstanceModalError, ofrNotResponding]) then
410 Exit;//handle only one running Lazarus IDE
411 end;
412 end;
413 finally
414 xStartClient.Free;
415 xServerIDs.Free;
416 end;
417 end;
418
StartUserBuiltIDEnull419 function TIDEInstances.StartUserBuiltIDE: TStartNewInstanceResult;
420 // check if this is the standard(nonwritable) IDE and there is a custom built IDE.
421 // if yes, start the custom IDE.
422 var
423 CustomDir, StartPath, DefaultDir, DefaultExe, CustomExe: String;
424 Params: TStringList;
425 aProcess: TProcessUTF8;
426 CfgParams: TStrings;
427 i: Integer;
428 aPID: SizeUInt;
429 Verbose: Boolean;
430 begin
431 Result:=ofrStartNewInstance;
432
433 aPID:=GetProcessID;
434 CfgParams:=GetParamsAndCfgFile;
435
436 Verbose:=(CfgParams.IndexOf('-v')>=0) or (CfgParams.IndexOf('--verbose')>=0);
437 if Verbose then
438 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE ']);
439
440 if CfgParams.IndexOf(StartedByStartLazarusOpt)>=0 then
441 exit; // startlazarus has started this exe -> do not redirect
442
443 try
444 StartPath:=ExpandFileNameUTF8(ParamStrUTF8(0));
445 if Verbose then
446 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE StartPath=',StartPath]);
447 if FileIsSymlink(StartPath) then
448 StartPath:=GetPhysicalFilename(StartPath,pfeException);
449 DefaultDir:=ExtractFilePath(StartPath);
450 if DirectoryExistsUTF8(DefaultDir) then
451 DefaultDir:=GetPhysicalFilename(DefaultDir,pfeException);
452 except
453 on E: Exception do begin
454 MessageDlg ('Error',E.Message,mtError,[mbCancel],0);
455 exit;
456 end;
457 end;
458 DefaultDir:=AppendPathDelim(DefaultDir);
459 CustomDir:=AppendPathDelim(GetPrimaryConfigPath) + 'bin' + PathDelim;
460 if Verbose then
461 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE DefaultDir=',DefaultDir,' CustomDir=',CustomDir]);
462 if CompareFilenames(DefaultDir,CustomDir)=0 then
463 exit; // this is the user built IDE
464
465 DefaultExe:=DefaultDir+'lazarus'+GetExeExt; // started IDE
466 CustomExe:=CustomDir+'lazarus'+GetExeExt; // user built IDE
467
468 if (not FileExistsUTF8(DefaultExe))
469 or (not FileExistsUTF8(CustomExe)) then
470 begin
471 if Verbose then
472 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE CustomExe=',CustomExe,' Exits=',FileExistsUTF8(CustomExe)]);
473 exit;
474 end;
475 if FileAgeUTF8(CustomExe)<FileAgeUTF8(DefaultExe) then
476 begin
477 if Verbose then
478 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE FileAge: Custom=',CustomExe,':',FileAgeUTF8(CustomExe),' < Default=',DefaultExe,':',FileAgeUTF8(DefaultExe)]);
479 exit;
480 end;
481 //debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE FileAge: Custom=',CustomExe,':',FileAgeUTF8(CustomExe),' >= Default=',DefaultExe,':',FileAgeUTF8(DefaultExe)]);
482
483 if DirectoryIsWritable(DefaultDir) then
484 begin
485 if Verbose then
486 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE Dir is writable: DefaultDir=',DefaultDir]);
487 exit;
488 end;
489
490 if Verbose then
491 debugln(['Debug: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE Starting custom IDE DefaultDir=',DefaultDir,' CustomDir=',CustomDir]);
492
493 // customexe is younger and defaultexe is not writable
494 // => the user started the default binary
495 // -> start the customexe
496 Params:=TStringList.Create;
497 aProcess:=nil;
498 try
499 aProcess := TProcessUTF8.Create(nil);
500 aProcess.InheritHandles := false;
501 aProcess.Options := [];
502 aProcess.ShowWindow := swoShow;
503 {$IFDEF Darwin}
504 if not DirectoryExistsUTF8(CustomExe+'.app') then
505 begin
506 debugln(['Note: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE user IDE is missing the .app folder: ',CustomExe]);
507 exit;
508 end;
509 aProcess.Executable:='/usr/bin/open';
510 Params.Add('-a');
511 CustomExe:=CustomExe+'.app';
512 Params.Add(CustomExe);
513 Params.Add('--args');
514 {$ELSE}
515 aProcess.Executable:=CustomExe;
516 {$ENDIF}
517 // append params, including the lazarus.cfg params
518 for i:=1 to CfgParams.Count-1 do
519 Params.Add(ExpandParamFile(CfgParams[i]));
520 aProcess.Parameters:=Params;
521 debugln(['Note: (lazarus) ',aPID,' TIDEInstances.StartUserBuiltIDE Starting custom IDE: aProcess.Executable=',aProcess.Executable,' Params=[',Params.Text,']']);
522 aProcess.Execute;
523 finally
524 Params.Free;
525 aProcess.Free;
526 end;
527 Result:=ofrDoNotStart;
528 end;
529
TIDEInstances.CheckParamsForForceNewInstanceOptnull530 function TIDEInstances.CheckParamsForForceNewInstanceOpt: Boolean;
531 var
532 I: Integer;
533 begin
534 Result := False;
535 for I := 1 to ParamsAndCfgCount do
536 if ParamIsOption(i, ForceNewInstanceOpt) then//ignore the settings and start new Lazarus IDE instance
537 Result := True;
538 end;
539
540 procedure TIDEInstances.PerformCheck;
541 var
542 xResult: TStartNewInstanceResult;
543 xModalErrorMessage: string = '';
544 xModalErrorForceUniqueMessage: string = '';
545 xNotRespondingErrorMessage: string = '';
546 xHandleBringToFront: HWND = 0;
547 PCP: String;
548 begin
549 if not FStartIDE then//InitIDEInstances->CollectOtherOpeningFiles decided not to start the IDE
550 Exit;
551
552 // set primary config path
553 PCP:=ExtractPrimaryConfigPath(GetParamsAndCfgFile);
554 if PCP<>'' then
555 SetPrimaryConfigPath(PCP);
556
557 if not FForceNewInstance then
558 begin
559 // check for already running instance
560 xResult := AllowStartNewInstance(FilesToOpen, xModalErrorMessage, xModalErrorForceUniqueMessage, xNotRespondingErrorMessage, xHandleBringToFront);
561
562 if xResult=ofrStartNewInstance then
563 begin
564 // check if there is an user built binary
565 xResult := StartUserBuiltIDE;
566 end;
567 end
568 else
569 xResult := ofrStartNewInstance;
570
571 if xModalErrorMessage = '' then
572 xModalErrorMessage := dlgRunningInstanceModalError;
573 if xNotRespondingErrorMessage = '' then
574 xNotRespondingErrorMessage := dlgRunningInstanceNotRespondingError;
575 if xModalErrorForceUniqueMessage = '' then
576 xModalErrorForceUniqueMessage := dlgForceUniqueInstanceModalError;
577
578 FStartIDE := (xResult = ofrStartNewInstance);
579 case xResult of
580 ofrModalError:
581 FStartIDE := MessageDlg(lisLazarusIDE, Format(xModalErrorMessage, [FilesToOpen.Text]), mtWarning, mbYesNo, 0, mbYes) = mrYes;
582 ofrNotResponding:
583 MessageDlg(lisLazarusIDE, xNotRespondingErrorMessage, mtError, [mbOK], 0);
584 ofrForceSingleInstanceModalError:
585 MessageDlg(lisLazarusIDE, xModalErrorForceUniqueMessage, mtError, [mbOK], 0);
586 end;
587
588 {$IFDEF MSWINDOWS}
589 if not FStartIDE and (xHandleBringToFront <> 0) then
590 begin
591 try
592 SetForegroundWindow(xHandleBringToFront);//SetForegroundWindow works (on Windows) only if the calling process is the foreground process, therefore it must be here!
593 except
594 //eat all widget exceptions
595 end;
596 end;
597 {$ENDIF}
598 end;
599
600 constructor TIDEInstances.Create(aOwner: TComponent);
601 begin
602 inherited Create(aOwner);
603
604 FStartIDE := True;
605 end;
606
607 destructor TIDEInstances.Destroy;
608 begin
609 StopServer;
610 FreeAndNil(FMainServer);
611 FreeAndNil(FFilesToOpen);
612
613 inherited Destroy;
614 end;
615
616 procedure TIDEInstances.CollectFiles(out
617 outFilesWereSentToCollectingServer: Boolean);
618
619 var
620 xThisClientMessageId: Integer;
621
622 procedure _SendToServer;
623 var
624 xClient: TIPCClient;
625 xOutParams: TMessageParams;
626 xStream: TMemoryStream;
627 begin
628 xClient := TIPCClient.Create(nil);
629 try
630 xClient.ServerID := SERVERNAME_COLLECT;
631
632 SetLength(xOutParams{%H-}, 0);
633 AddFilesToParams(FilesToOpen, xOutParams);
634
635 xStream := TMemoryStream.Create;
636 try
637 BuildMessage(MESSAGE_COLLECTFILES, xOutParams, xStream);
638 xStream.Position := 0;
639 xThisClientMessageId := xClient.PostRequest(MESSAGETYPE_XML, xStream);
640 finally
641 xStream.Free;
642 end;
643 finally
644 xClient.Free;
645 end;
646 end;
647
648 procedure _WaitForFiles;
649 var
650 xLastCount, xNewCount: Integer;
651 xServer: TIPCServer;
652 begin
653 xServer := TIPCServer.Create(nil);
654 try
655 xServer.ServerID := SERVERNAME_COLLECT;
656 //do not start server here
657 xLastCount := -1;
658 xNewCount := xServer.GetPendingRequestCount;
659 while xLastCount <> xNewCount do
660 begin
661 xLastCount := xNewCount;
662 Sleep(TIMEOUT_COLLECTFILES);
663 xNewCount := xServer.GetPendingRequestCount;
664 end;
665 finally
666 xServer.Free;
667 end;
668 end;
669
_ReceiveAsServernull670 function _ReceiveAsServer: Boolean;
671 var
672 xServer: TIPCServer;
673 xInParams: TMessageParams;
674 xStream: TMemoryStream;
675 xMsgType: Integer;
676 xMessageType: string;
677 begin
678 xStream := TMemoryStream.Create;
679 xServer := TIPCServer.Create(nil);
680 try
681 xServer.ServerID := SERVERNAME_COLLECT;
682 //files have to be handled only by one instance!
683 Result := xServer.FindHighestPendingRequestId = xThisClientMessageId;
684 if Result then
685 begin
686 //we are the highest client, handle the files
687 xServer.StartServer(False);
688 end else
689 begin
690 //we are not the highest client, maybe there are pending files, check that
691 {$IFNDEF MSWINDOWS}
692 //this code is not slowing up IDE start because if there was highest client found (the normal way), we close anyway
693 Randomize; //random sleep in order to prevent double file locks on unix
694 Sleep((PtrInt(Random($3F)) + {%H-}PtrInt(GetCurrentThreadId)) and $3F);
695 {$ENDIF}
696 if not (xServer.StartServer(False) and (xServer.GetPendingRequestCount > 0)) then
697 Exit;//server is already running or there are no pending message -> close
698 Result := True;//no one handled handled the files, do it by myself
699 end;
700
701 FilesToOpen.Clear;
702 while xServer.PeekRequest(xStream, xMsgType{%H-}) do
703 if xMsgType = MESSAGETYPE_XML then
704 begin
705 if ParseMessage(xStream, xMessageType, xInParams) and
706 (xMessageType = MESSAGE_COLLECTFILES)
707 then
708 AddFilesFromParams(xInParams, FilesToOpen);
709 end;
710 finally
711 xStream.Free;
712 xServer.Free;
713 end;
714 end;
715 begin
716 //if you select more files in explorer and open them, they are not opened in one process but one process is started per file
717 // -> collect them
718
719 //first send messages to queue (there is no server, no problem, it will collect the messages when it is created)
720 _SendToServer;
721
722 //now wait until we have everything
723 _WaitForFiles;
724
725 //now send them to one instance
726 outFilesWereSentToCollectingServer := not _ReceiveAsServer;
727 end;
728
729 procedure TIDEInstances.InitIDEInstances;
730 var
731 xFilesWereSentToCollectingServer: Boolean;
732 I: Integer;
733 begin
734 FForceNewInstance := CheckParamsForForceNewInstanceOpt;
735
736 //get cmd line filenames
737 FFilesToOpen := ExtractCmdLineFilenames;
738 for I := 0 to FilesToOpen.Count-1 do
739 FilesToOpen[I] := CleanAndExpandFilename(FilesToOpen[I]);
740
741 if FilesToOpen.Count > 0 then//if there are file in the cmd, check for multiple starting instances
742 begin
743 CollectFiles(xFilesWereSentToCollectingServer);
744 if xFilesWereSentToCollectingServer then
745 begin
746 FilesToOpen.Clear;
747 FStartIDE := False;
748 end;
749 end;
750 end;
751
752 { TUniqueServer }
753
754 procedure TUniqueServer.StartUnique(const aServerPrefix: string);
755 var
756 I: Integer;
757 Tmp: String;
758 begin
759 if Active then
760 StopServer;
761
762 I := 0;
763 while not Active do
764 begin
765 Inc(I);
766 ServerID := aServerPrefix+Format('%.2d',[I]);
767 // FileName is composed of TempDir and ServerID. Make sure TempDir exists.
768 Tmp := GetTempDir(Global); // Use TIPCBase.Global property also here.
769 if not DirectoryExists(Tmp) then
770 ForceDirectories(Tmp);
771 StartServer; // This uses the FileName in TempDir.
772 end;
773 end;
774
775 { TResponseClient }
776
AllowStartNewInstancenull777 function TResponseClient.AllowStartNewInstance(const aFiles: TStrings;
778 var outModalErrorMessage, outModalErrorForceUniqueMessage,
779 outNotRespondingErrorMessage: string; var outHandleBringToFront: HWND
780 ): TStartNewInstanceResult;
781 var
782 xStream: TMemoryStream;
783 xMsgType: Integer;
784 xResponseType: string;
785 xOutParams, xInParams: TMessageParams;
786 begin
787 Result := ofrStartNewInstance;
788 xStream := TMemoryStream.Create;
789 try
790 //ask to show prompt
791 xStream.Clear;
792 SetLength(xOutParams{%H-}, 0);
793 TIDEInstances.AddFilesToParams(aFiles, xOutParams);
794 TIDEInstances.BuildMessage(MESSAGE_STARTNEWINSTANCE, xOutParams, xStream);
795 xStream.Position := 0;
796 Self.PostRequest(MESSAGETYPE_XML, xStream);
797 xStream.Clear;
798 if PeekResponse(xStream, xMsgType{%H-}, TIMEOUT_OPENFILES) and
799 (xMsgType = MESSAGETYPE_XML) then
800 begin
801 xStream.Position := 0;
802 if TIDEInstances.ParseMessage(xStream, xResponseType, xInParams) and
803 (xResponseType = RESPONSE_OPENFILES) then
804 begin
805 Result := TStartNewInstanceResult(StrToIntDef(TIDEInstances.GetMessageParam(xInParams, PARAM_RESULT), 0));
806 outModalErrorMessage := TIDEInstances.GetMessageParam(xInParams, PARAM_MODALERRORMESSAGE);
807 outModalErrorForceUniqueMessage := TIDEInstances.GetMessageParam(xInParams, PARAM_FORCEUNIQUEMODALERRORMESSAGE);
808 outNotRespondingErrorMessage := TIDEInstances.GetMessageParam(xInParams, PARAM_NOTRESPONDINGERRORMESSAGE);
809 outHandleBringToFront := StrToInt64Def(TIDEInstances.GetMessageParam(xInParams, PARAM_HANDLEBRINGTOFRONT), 0);
810 end;
811 end else//no response
812 begin
813 DeleteRequest;
814 Result := ofrNotResponding;
815 end;
816 finally
817 xStream.Free;
818 end;
819 end;
820
TResponseClient.GetCurrentProjectFileNamenull821 function TResponseClient.GetCurrentProjectFileName: string;
822 var
823 xStream: TMemoryStream;
824 xMsgType: Integer;
825 xResponseType: string;
826 xOutParams, xInParams: TMessageParams;
827 begin
828 Result := '';
829 xStream := TMemoryStream.Create;
830 try
831 xStream.Clear;
832 SetLength(xOutParams{%H-}, 0);
833 TIDEInstances.BuildMessage(MESSAGE_GETOPENEDPROJECT, xOutParams, xStream);
834 xStream.Position := 0;
835 Self.PostRequest(MESSAGETYPE_XML, xStream);
836 xStream.Clear;
837 if PeekResponse(xStream, xMsgType{%H-}, TIMEOUT_GETOPENEDPROJECT) and
838 (xMsgType = MESSAGETYPE_XML) then
839 begin
840 xStream.Position := 0;
841 if TIDEInstances.ParseMessage(xStream, xResponseType, xInParams) and
842 (xResponseType = RESPONSE_GETOPENEDPROJECT) then
843 begin
844 Result := TIDEInstances.GetMessageParam(xInParams, PARAM_RESULT);
845 end;
846 end else//no response
847 begin
848 DeleteRequest;
849 Result := '';
850 end;
851 finally
852 xStream.Free;
853 end;
854 end;
855
856 { TMainServer }
857
858 procedure TMainServer.CheckMessagesOnTimer(Sender: TObject);
859 begin
860 DoCheckMessages;
861 end;
862
863 constructor TMainServer.Create(aOwner: TComponent);
864 begin
865 inherited Create(aOwner);
866
867 FMsgStream := TMemoryStream.Create;
868 end;
869
870 destructor TMainServer.Destroy;
871 begin
872 FMsgStream.Free;
873 StopListening;
874
875 inherited Destroy;
876 end;
877
878 procedure TMainServer.DoStartNewInstance(const aMsgID: Integer;
879 const aInParams: TMessageParams);
880 var
881 xResult: TStartNewInstanceResult;
882 xFiles: TStrings;
883 xParams: TMessageParams;
884 xSourceWindowHandle: HWND = 0;
885 begin
886 xResult := ofrStartNewInstance;
887 if Assigned(FStartNewInstanceEvent) then
888 begin
889 xFiles := TStringList.Create;
890 try
891 TIDEInstances.AddFilesFromParams(aInParams, xFiles);
892 FStartNewInstanceEvent(xFiles, xResult, xSourceWindowHandle);
893 finally
894 xFiles.Free;
895 end;
896 end;
897
898 SetLength(xParams{%H-}, 5);
899 xParams[0] := TIDEInstances.MessageParam(PARAM_RESULT, IntToStr(Ord(xResult)));
900 xParams[1] := TIDEInstances.MessageParam(PARAM_HANDLEBRINGTOFRONT, IntToStr(xSourceWindowHandle)); // do not use Application.MainFormHandle here - it steals focus from active source editor
901 xParams[2] := TIDEInstances.MessageParam(PARAM_MODALERRORMESSAGE, dlgRunningInstanceModalError);
902 xParams[3] := TIDEInstances.MessageParam(PARAM_FORCEUNIQUEMODALERRORMESSAGE, dlgForceUniqueInstanceModalError);
903 xParams[4] := TIDEInstances.MessageParam(PARAM_NOTRESPONDINGERRORMESSAGE, dlgRunningInstanceNotRespondingError);
904 SimpleResponse(aMsgID, RESPONSE_OPENFILES, xParams);
905 end;
906
907 procedure TMainServer.SimpleResponse(const aResponseToMsgID: Integer; const
908 aResponseType: string; const aParams: array of TMessageParam);
909 var
910 xStream: TMemoryStream;
911 begin
912 xStream := TMemoryStream.Create;
913 try
914 TIDEInstances.BuildMessage(aResponseType, aParams, xStream);
915 xStream.Position := 0;
916 PostResponse(aResponseToMsgID, MESSAGETYPE_XML, xStream);
917 finally
918 xStream.Free;
919 end;
920 end;
921
922 procedure TMainServer.StartListening(
923 const aStartNewInstanceEvent: TStartNewInstanceEvent;
924 const aGetCurrentProjectEvent: TGetCurrentProjectEvent);
925 begin
926 Assert((FTimer = nil) and Assigned(aStartNewInstanceEvent) and Assigned(aGetCurrentProjectEvent));
927
928 FTimer := TTimer.Create(nil);
929 FTimer.OnTimer := @CheckMessagesOnTimer;
930 FTimer.Interval := 50;
931 FTimer.Enabled := True;
932
933 FStartNewInstanceEvent := aStartNewInstanceEvent;
934 FGetCurrentProjectEvent := aGetCurrentProjectEvent;
935 end;
936
937 procedure TMainServer.StopListening;
938 begin
939 FreeAndNil(FTimer);
940
941 FStartNewInstanceEvent := nil;
942 end;
943
944 procedure TMainServer.DoCheckMessages;
945 var
946 xMessageType: string;
947 xParams: TMessageParams;
948 xMsgID, xMsgType: Integer;
949 begin
950 if Active then
951 begin
952 while
953 PeekRequest(FMsgStream, xMsgID{%H-}, xMsgType{%H-}) and
954 (xMsgType = MESSAGETYPE_XML) and
955 (TIDEInstances.ParseMessage(FMsgStream, xMessageType, xParams))
956 do
957 case xMessageType of
958 MESSAGE_STARTNEWINSTANCE: DoStartNewInstance(xMsgID, xParams);
959 MESSAGE_GETOPENEDPROJECT: DoGetCurrentProject(xMsgID, xParams);
960 end;
961 end;
962 end;
963
964 procedure TMainServer.DoGetCurrentProject(const aMsgID: Integer;
965 const aInParams: TMessageParams);
966 var
967 xResult: string;
968 xParams: TMessageParams;
969 begin
970 xResult := '';
971 if Assigned(FStartNewInstanceEvent) then
972 FGetCurrentProjectEvent(xResult);
973
974 SetLength(xParams{%H-}, 1);
975 xParams[0] := TIDEInstances.MessageParam(PARAM_RESULT, xResult);
976 SimpleResponse(aMsgID, RESPONSE_GETOPENEDPROJECT, xParams);
977 end;
978
979 initialization
980 FLazIDEInstances := TIDEInstances.Create(nil);
981 FLazIDEInstances.InitIDEInstances;
982
983 finalization
984 FreeAndNil(FLazIDEInstances);
985
986 end.
987