diff --git a/ide/advancedipc.pp b/ide/advancedipc.pp index 9f660e6abb..481fa2e797 100644 --- a/ide/advancedipc.pp +++ b/ide/advancedipc.pp @@ -222,8 +222,9 @@ function TIPCBase.GetUniqueRequest(out outFileName: string): Integer; begin Randomize; repeat - //if Randomize/Random is started from 2 processes at exactly same moment, it returns the same number! -> prevent duplicates by adding GetCurrentThreadId - Result := Integer(Int64(Random(High(Integer)))+GetCurrentThreadId); + //if Randomize/Random is started from 2 processes at exactly same moment, it returns the same number! -> prevent duplicates by xor GetCurrentThreadId + //the result must be of range 0..$7FFFFFFF (High(Integer)) + Result := Integer((Int64(Random($7FFFFFFF)) xor GetCurrentThreadId) and $7FFFFFFF); outFileName := GetRequestFileName(Result); until not RequestExists(outFileName); end; @@ -520,19 +521,15 @@ end; function TIPCServer.FindHighestPendingRequestId: Integer; var xRec: {$IF FPC_FULLVERSION>=20701}TRawByteSearchRec{$ELSE}TSearchRec{$ENDIF}; - xRequestID, xHighestId: LongInt; + xRequestID: LongInt; begin - xHighestId := -1; Result := -1; if FindFirst(GetRequestPrefix+'*', faAnyFile, xRec) = 0 then begin repeat xRequestID := RequestFileNameToID(xRec.Name); - if xRequestID > xHighestId then - begin - xHighestId := xRequestID; + if xRequestID > Result then Result := xRequestID; - end; until FindNext(xRec) <> 0; end; FindClose(xRec); diff --git a/ide/ideinstances.pas b/ide/ideinstances.pas index 34a2f85b58..7d6711ae65 100644 --- a/ide/ideinstances.pas +++ b/ide/ideinstances.pas @@ -735,786 +735,3 @@ finalization FreeAndNil(FLazIDEInstances); end. -{ - /*************************************************************************** - ideinstances.pas - ---------------- - - ***************************************************************************/ - - *************************************************************************** - * * - * This source is free software; you can redistribute it and/or modify * - * it under the terms of the GNU General Public License as published by * - * the Free Software Foundation; either version 2 of the License, or * - * (at your option) any later version. * - * * - * This code is distributed in the hope that it will be useful, but * - * WITHOUT ANY WARRANTY; without even the implied warranty of * - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * - * General Public License for more details. * - * * - * A copy of the GNU General Public License is available on the World * - * Wide Web at . You can also * - * obtain it by writing to the Free Software Foundation, * - * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * - * * - *************************************************************************** - - Author: Ondrej Pokorny - - Abstract: - This unit handles one/multiple Lazarus IDE instances. - -} -unit IDEInstances; - -{$mode objfpc}{$H+} - -interface - -uses - sysutils, Interfaces, Classes, Controls, Forms, Dialogs, ExtCtrls, - LCLProc, LCLIntf, LCLType, AdvancedIPC, - LazFileUtils, LazUTF8, Laz2_DOM, laz2_XMLRead, laz2_XMLWrite, - LazarusIDEStrConsts, IDECmdLine; - -type - TIDEStartWithFilesAction = (isaStartNewInstance, isaOpenFilesInRunningInstance, isaPrompt, isaModalError); - TChooseActionEvent = procedure( - const aFiles: TStrings; - var Result: TIDEStartWithFilesAction; - var outPromptMessage: string; - var outOpenNewInstanceMessage: string) of object;//we want to receive translated outPromptMessage and outOpenNewInstanceMessage -> do not read them directly from LazarusIDEStrConsts here - TOpenFilesResult = (ofrStartNewInstance, ofrDoNotStart, ofrModalError); - TOpenFilesEvent = procedure(const aFiles: TStrings; - var outResult: TOpenFilesResult; var outHandleBringToFront: HWND) of object; - - TMessageParam = record - Name: string; - Value: string; - end; - TMessageParams = array of TMessageParam; - - TUniqueServer = class(TIPCServer) - public - procedure StartUnique(const aServerPrefix: string); - end; - - TMainServer = class(TUniqueServer) - private - FOpenFilesEvent: TOpenFilesEvent; - FChooseActionEvent: TChooseActionEvent; - FTimer: TTimer; - FMsgStream: TMemoryStream; - - procedure DoChooseActionEvent(const aMsgID: string; const aInParams: TMessageParams); - procedure DoOpenFiles(const aMsgID: string; const aInParams: TMessageParams); - - procedure SimpleResponse( - const aResponseToMsgID, aResponseType: string; - const aParams: array of TMessageParam); - - procedure DoCheckMessages; - procedure CheckMessagesOnTimer(Sender: TObject); - - public - constructor Create; override; - destructor Destroy; override; - end; - - TResponseClient = class(TIPCClient) - public - function SendFilesToRunningInstance( - const aFiles: TStrings; var outOpenNewInstanceMessage: string; - var outHandleBringToFront: HWND): TOpenFilesResult; - end; - - TIDEInstances = class - private - FMainServer: TMainServer;//running IDE - FStartIDE: Boolean;// = True; - FForceNewInstance: Boolean; - FAllowOpenLastProject: Boolean;// = True; - FFilesToOpen: TStrings; - - class procedure AddFilesToParams(const aFiles: TStrings; - var ioParams: TMessageParams); static; - class procedure AddFilesFromParams(const aInParams: TMessageParams; - const aFiles: TStrings); static; - class procedure BuildMessage(const aMessageType: string; - const aParams: array of TMessageParam; const aStream: TStream); static; - class function MessageParam(const aName, aValue: string): TMessageParam; static; - class function ParseMessage(const aStream: TStream; out outMessageType: string; - out outParams: TMessageParams): Boolean; static; - class function GetMessageParam(const aParams: array of TMessageParam; - const aParamName: string): string; static; - - function CheckParamsForForceNewInstanceOpt: Boolean; - - procedure CollectFiles(out - outFilesWereSentToCollectingServer: Boolean); - - function SendFilesToRunningInstance(const aFiles: TStrings; - var outOpenNewInstanceMessage: string; var outHandleBringToFront: HWND): TOpenFilesResult; - procedure InitIDEInstances; - public - constructor Create; - destructor Destroy; override; - public - procedure PerformCheck;//call PerformCheck after Application.Initialize - it can open dialogs! - - procedure StartListening(const aOpenFilesEvent: TOpenFilesEvent; - const aChooseActionEvent: TChooseActionEvent); - procedure StopListening; - function StartIDE: Boolean;//can the IDE be started? - function AllowOpenLastProject: Boolean;//if a secondary IDE is starting, do NOT reopen last project! - function FilesToOpen: TStrings; - procedure DeleteCollectMessageFiles; - end; - -function LazIDEInstances: TIDEInstances; - -implementation - -const - SERVERPREFIX_MAIN = 'LazarusMain'; - SERVERNAME_COLLECT = 'LazarusCollect'; - MESSAGETYPE_XML = 2; - ELEMENT_ROOT = 'ideinstances'; - ATTR_VALUE = 'value'; - ATTR_MESSAGE_TYPE = 'msgtype'; - MESSAGE_CHOOSEACTION = 'chooseaction'; - RESPONSE_SHOWPROMPT = 'showprompt'; - MESSAGE_OPENFILES = 'openfiles'; - MESSAGE_COLLECTFILES = 'collectfiles'; - RESPONSE_STARTNEWINSTANCE = 'startnewinstance'; - PARAM_FILE = 'file'; - PARAM_RESULT = 'result'; - PARAM_HANDLEBRINGTOFRONT = 'handlebringtofront'; - PARAM_PROMPTMESSAGE = 'promptmessage'; - PARAM_OPENNEWINSTANCEMESSAGE = 'opennewinstancemessage'; - MAX_CHECK_INSTANCES = 10;//check maximum count of continuously started instances - TIMEOUT_COLLECTFILES = 100; - TIMEOUT_SHOWPROMPT = 500;//first timeout is 1/2 second, we should get an answer fast - TIMEOUT_STARTNEWINSTANCE = 3000;//we know that Lazarus is already running and responding so we get an answer, the UnHide process could take some time, let's wait for it max 3 seconds - -var - FLazIDEInstances: TIDEInstances; - -function LazIDEInstances: TIDEInstances; -begin - Result := FLazIDEInstances; -end; - -{ TIDEInstances } - -class function TIDEInstances.MessageParam(const aName, aValue: string): TMessageParam; -begin - Result.Name := aName; - Result.Value := aValue; -end; - -function TIDEInstances.StartIDE: Boolean; -begin - Result := FStartIDE; -end; - -function TIDEInstances.AllowOpenLastProject: Boolean; -begin - Result := FAllowOpenLastProject; -end; - -function TIDEInstances.FilesToOpen: TStrings; -begin - if not Assigned(FFilesToOpen) then - FFilesToOpen := TStringList.Create; - Result := FFilesToOpen; -end; - -procedure TIDEInstances.StartListening(const aOpenFilesEvent: TOpenFilesEvent; - const aChooseActionEvent: TChooseActionEvent); -begin - Assert(Assigned(aOpenFilesEvent) and Assigned(aChooseActionEvent)); - - if not Assigned(FMainServer) then - begin - FMainServer := TMainServer.Create; - FMainServer.StartUnique(SERVERPREFIX_MAIN); - end; - FMainServer.FOpenFilesEvent := aOpenFilesEvent; - FMainServer.FChooseActionEvent := aChooseActionEvent; - - DeleteCollectMessageFiles; -end; - -procedure TIDEInstances.StopListening; -begin - FreeAndNil(FMainServer); -end; - -class procedure TIDEInstances.AddFilesFromParams( - const aInParams: TMessageParams; const aFiles: TStrings); -var - I: Integer; -begin - //do not clear aFiles - for I := Low(aInParams) to High(aInParams) do - if aInParams[I].Name = PARAM_FILE then - aFiles.Add(aInParams[I].Value); -end; - -class procedure TIDEInstances.AddFilesToParams(const aFiles: TStrings; - var ioParams: TMessageParams); -var - xStartIndex: Integer; - I: Integer; -begin - xStartIndex := Length(ioParams); - SetLength(ioParams, xStartIndex+aFiles.Count); - for I := 0 to aFiles.Count-1 do - ioParams[xStartIndex+I] := MessageParam(PARAM_FILE, aFiles[I]); -end; - -class function TIDEInstances.GetMessageParam( - const aParams: array of TMessageParam; const aParamName: string): string; -var - I: Integer; -begin - for I := 0 to Length(aParams) do - if aParams[I].Name = aParamName then - Exit(aParams[I].Value); - - Result := '';//not found -end; - -class procedure TIDEInstances.BuildMessage(const aMessageType: string; - const aParams: array of TMessageParam; const aStream: TStream); -var - xDOM: TXMLDocument; - xRoot: TDOMElement; - xParam: TDOMElement; - I: Integer; -begin - xDOM := TXMLDocument.Create; - try - xRoot := xDOM.CreateElement(ELEMENT_ROOT); - xRoot.AttribStrings[ATTR_MESSAGE_TYPE] := aMessageType; - xDOM.AppendChild(xRoot); - - for I := Low(aParams) to High(aParams) do - begin - xParam := xDOM.CreateElement(aParams[I].Name); - xRoot.AppendChild(xParam); - xParam.AttribStrings[ATTR_VALUE] := aParams[I].Value; - end; - - WriteXMLFile(xDOM, aStream); - finally - xDOM.Free; - end; -end; - -class function TIDEInstances.ParseMessage(const aStream: TStream; out - outMessageType: string; out outParams: TMessageParams): Boolean; -var - xDOM: TXMLDocument; - xChildList: TDOMNodeList; - I, J: Integer; -begin - Result := False; - - outMessageType := ''; - SetLength(outParams, 0); - try - ReadXMLFile(xDOM, aStream, []); - except - on EXMLReadError do - Exit;//eat XML exceptions - end; - try - if (xDOM = nil) or (xDOM.DocumentElement = nil) or (xDOM.DocumentElement.NodeName <> ELEMENT_ROOT) then - Exit; - - outMessageType := xDOM.DocumentElement.AttribStrings[ATTR_MESSAGE_TYPE]; - - xChildList := xDOM.DocumentElement.ChildNodes; - SetLength(outParams, xChildList.Count); - J := 0; - for I := 0 to xChildList.Count-1 do - if xChildList[I] is TDOMElement then - begin - outParams[J].Name := xChildList[I].NodeName; - outParams[J].Value := TDOMElement(xChildList[I]).AttribStrings[ATTR_VALUE]; - Inc(J); - end; - SetLength(outParams, J); - Result := True; - finally - xDOM.Free; - end; -end; - -function TIDEInstances.SendFilesToRunningInstance(const aFiles: TStrings; - var outOpenNewInstanceMessage: string; var outHandleBringToFront: HWND - ): TOpenFilesResult; -var - xStartClient: TResponseClient; - I: Integer; -begin - Result := ofrStartNewInstance; - xStartClient := TResponseClient.Create; - try - for I := 1 to MAX_CHECK_INSTANCES do//check for multiple instances - begin - xStartClient.ServerName := SERVERPREFIX_MAIN+IntToStr(I); - if xStartClient.ServerRunning then - begin - //there are open Lazarus instances, do not reopen last project! - FAllowOpenLastProject := False; - Result := xStartClient.SendFilesToRunningInstance(aFiles, outOpenNewInstanceMessage, outHandleBringToFront); - if Result <> ofrModalError then//if the current IDE is modal, try another one - Exit;//handle only one running Lazarus IDE - end; - end; - finally - xStartClient.Free; - end; -end; - -function TIDEInstances.CheckParamsForForceNewInstanceOpt: Boolean; -var - I: Integer; -begin - Result := False; - for I := 1 to ParamsAndCfgCount do - if ParamIsOption(i, ForceNewInstanceOpt) then//ignore the settings and start new Lazarus IDE instance - Result := True; -end; - -procedure TIDEInstances.DeleteCollectMessageFiles; -var - xServer: TIPCServer; -begin - xServer := TIPCServer.Create; - try - xServer.ServerName := SERVERNAME_COLLECT; - xServer.DeletePendingRequests; - finally - xServer.Free; - end; -end; - -procedure TIDEInstances.PerformCheck; -var - xResult: TOpenFilesResult; - xOpenNewInstanceMessage: string = ''; - xHandleBringToFront: HWND = 0; -begin - if not FStartIDE then//InitIDEInstances->CollectOtherOpeningFiles decided not to start the IDE - Exit; - - if not FForceNewInstance and (FilesToOpen.Count > 0) then - xResult := SendFilesToRunningInstance(FilesToOpen, xOpenNewInstanceMessage, xHandleBringToFront) - else - xResult := ofrStartNewInstance; - - if xOpenNewInstanceMessage = '' then - xOpenNewInstanceMessage := dlgRunningInstanceModalOpenNew; - FStartIDE := - (xResult = ofrStartNewInstance) or - ((xResult = ofrModalError) and - (MessageDlg(lisLazarusIDE, Format(xOpenNewInstanceMessage, [FilesToOpen.Text]), mtWarning, mbYesNo, 0, mbYes) = mrYes));//user decided to open in new ide - - {$IFDEF MSWINDOWS} - if not FStartIDE and (xHandleBringToFront <> 0) then - begin - try - SetForegroundWindow(xHandleBringToFront);//SetForegroundWindow works (on Windows) only if the calling process is the foreground process, therefore it must be here! - except - //eat all widget exceptions - end; - end; - {$ENDIF} -end; - -constructor TIDEInstances.Create; -begin - inherited Create; - - FStartIDE := True; - FAllowOpenLastProject := True; -end; - -destructor TIDEInstances.Destroy; -begin - FreeAndNil(FMainServer); - FreeAndNil(FFilesToOpen); - - inherited Destroy; -end; - -procedure TIDEInstances.CollectFiles(out - outFilesWereSentToCollectingServer: Boolean); - -var - xThisClientMessageId: string; - - procedure _SendToServer; - var - xClient: TIPCClient; - xOutParams: TMessageParams; - xStream: TMemoryStream; - begin - xClient := TIPCClient.Create; - try - xClient.ServerName := SERVERNAME_COLLECT; - - SetLength(xOutParams, 0); - AddFilesToParams(FilesToOpen, xOutParams); - - xStream := TMemoryStream.Create; - try - BuildMessage(MESSAGE_COLLECTFILES, xOutParams, xStream); - xStream.Position := 0; - xClient.PostRequest(MESSAGETYPE_XML, xStream, xThisClientMessageId); - finally - xStream.Free; - end; - finally - xClient.Free; - end; - end; - - procedure _WaitForFiles; - var - xLastCount, xNewCount: Integer; - xServer: TIPCServer; - begin - xServer := TIPCServer.Create; - try - xServer.ServerName := SERVERNAME_COLLECT; - //do not start server here - xLastCount := -1; - xNewCount := xServer.GetPendingRequestCount; - while xLastCount <> xNewCount do - begin - xLastCount := xNewCount; - Sleep(TIMEOUT_COLLECTFILES); - xNewCount := xServer.GetPendingRequestCount; - end; - finally - xServer.Free; - end; - end; - - function _ReceiveAsServer: Boolean; - var - xServer: TIPCServer; - xInParams: TMessageParams; - xStream: TMemoryStream; - xMsgType: Integer; - xMessageType: string; - begin - xStream := TMemoryStream.Create; - xServer := TIPCServer.Create; - try - xServer.ServerName := SERVERNAME_COLLECT; - //files have to be handled only by one instance! - Result := xServer.FindHighestPendingRequestId = xThisClientMessageId; - if Result then - begin - //we are the highest client, handle the files - xServer.StartServer(False); - end else - begin - //we are not the highest client, maybe there are pending files, check that - {$IFNDEF MSWINDOWS} - //this code is not slowing up IDE start because if there was highest client found (the normal way), we close anyway - Randomize; - Sleep(50+Random(50));//random sleep in order to prevent double file locks on linux - {$ENDIF} - if not (xServer.StartServer(False) and (xServer.GetPendingRequestCount > 0)) then - Exit;//server is already running or there are no pending message -> close - Result := True;//no one handled handled the files, do it by myself - end; - - FilesToOpen.Clear; - while xServer.PeekRequest(xStream, xMsgType{%H-}) do - if xMsgType = MESSAGETYPE_XML then - begin - if ParseMessage(xStream, xMessageType, xInParams) and - (xMessageType = MESSAGE_COLLECTFILES) - then - AddFilesFromParams(xInParams, FilesToOpen); - end; - finally - xStream.Free; - xServer.Free; - end; - end; -begin - //if you select more files in explorer and open them, they are not opened in one process but one process is started per file - // -> collect them - - //first send messages to queue (there is no server, no problem, it will collect the messages when it is created) - _SendToServer; - - //now wait until we have everything - _WaitForFiles; - - //now send them to one instance - outFilesWereSentToCollectingServer := not _ReceiveAsServer; -end; - -procedure TIDEInstances.InitIDEInstances; -var - xFilesWereSentToCollectingServer: Boolean; -begin - FForceNewInstance := CheckParamsForForceNewInstanceOpt; - - //get cmd line filenames - FFilesToOpen := ExtractCmdLineFilenames; - - if FilesToOpen.Count > 0 then//if there are file in the cmd, check for multiple starting instances - begin - CollectFiles(xFilesWereSentToCollectingServer); - if xFilesWereSentToCollectingServer then - begin - FilesToOpen.Clear; - FStartIDE := False; - end; - end; -end; - -{ TUniqueServer } - -procedure TUniqueServer.StartUnique(const aServerPrefix: string); -var - I: Integer; -begin - if Active then - StopServer; - - I := 0; - while not Active do - begin - Inc(I); - ServerName := aServerPrefix+IntToStr(I); - StartServer; - end; -end; - -{ TResponseClient } - -function TResponseClient.SendFilesToRunningInstance(const aFiles: TStrings; - var outOpenNewInstanceMessage: string; var outHandleBringToFront: HWND - ): TOpenFilesResult; -var - xStream: TMemoryStream; - xMsgType: Integer; - xResponseType: string; - xOutParams, xInParams: TMessageParams; - xChooseAction: TIDEStartWithFilesAction; - xPromptMessage: string; -begin - Result := ofrStartNewInstance; - xStream := TMemoryStream.Create; - try - //ask to show prompt - xChooseAction := isaStartNewInstance; - SetLength(xOutParams, 0); - TIDEInstances.AddFilesToParams(aFiles, xOutParams); - TIDEInstances.BuildMessage(MESSAGE_CHOOSEACTION, xOutParams, xStream); - xStream.Position := 0; - PostRequest(MESSAGETYPE_XML, xStream); - xStream.Clear; - if PeekResponse(xStream, xMsgType{%H-}, TIMEOUT_SHOWPROMPT) and - (xMsgType = MESSAGETYPE_XML) then - begin - xStream.Position := 0; - if TIDEInstances.ParseMessage(xStream, xResponseType, xInParams) and - (xResponseType = RESPONSE_SHOWPROMPT) then - begin - xChooseAction := TIDEStartWithFilesAction(StrToIntDef(TIDEInstances.GetMessageParam(xInParams, PARAM_RESULT), 0)); - outOpenNewInstanceMessage := TIDEInstances.GetMessageParam(xInParams, PARAM_OPENNEWINSTANCEMESSAGE); - xPromptMessage := TIDEInstances.GetMessageParam(xInParams, PARAM_PROMPTMESSAGE); - if xChooseAction = isaModalError then - Exit(ofrModalError); - end; - end else//no response, the IDE is modal and cannot accept messages - begin - DeleteRequest; - Exit(ofrModalError); - end; - - case xChooseAction of - isaPrompt: - begin - if xPromptMessage = '' then - xPromptMessage := dlgOpenInRunningInstance; - case MessageDlg(lisLazarusIDE, Format(xPromptMessage, [aFiles.Text]), mtConfirmation, mbYesNo, 0, mbYes) of - mrYes: begin end;//user hit "yes" -> proceed - mrNo: Exit(ofrStartNewInstance);//user hit "no" -> open new instance - else//cancel/close -> do nothing, do not open IDE - Exit(ofrDoNotStart); - end; - end; - isaStartNewInstance://settings is startnewide -> open new instance - Exit(ofrStartNewInstance); - end; - - //open files in new instance - xStream.Clear; - TIDEInstances.BuildMessage(MESSAGE_OPENFILES, xOutParams, xStream); - xStream.Position := 0; - Self.PostRequest(MESSAGETYPE_XML, xStream); - xStream.Clear; - if PeekResponse(xStream, xMsgType, TIMEOUT_STARTNEWINSTANCE) and - (xMsgType = MESSAGETYPE_XML) then - begin - xStream.Position := 0; - if TIDEInstances.ParseMessage(xStream, xResponseType, xInParams) and - (xResponseType = RESPONSE_STARTNEWINSTANCE) then - begin - Result := TOpenFilesResult(StrToIntDef(TIDEInstances.GetMessageParam(xInParams, PARAM_RESULT), 0)); - outHandleBringToFront := StrToInt64Def(TIDEInstances.GetMessageParam(xInParams, PARAM_HANDLEBRINGTOFRONT), 0); - end; - end else//no response, the IDE is modal and cannot accept messages - begin - DeleteRequest; - Exit(ofrModalError); - end; - finally - xStream.Free; - end; -end; - -{ TMainServer } - -procedure TMainServer.CheckMessagesOnTimer(Sender: TObject); -begin - DoCheckMessages; -end; - -constructor TMainServer.Create; -begin - inherited Create; - - FMsgStream := TMemoryStream.Create; - FTimer := TTimer.Create(nil); - FTimer.OnTimer := @CheckMessagesOnTimer; - FTimer.Interval := 50; - FTimer.Enabled := True; -end; - -destructor TMainServer.Destroy; -begin - FMsgStream.Free; - FTimer.Free;//must free manually before inherited Destroy - - inherited Destroy; -end; - -procedure TMainServer.DoChooseActionEvent(const aMsgID: string; - const aInParams: TMessageParams); -var - xResult: TIDEStartWithFilesAction; - xParams: TMessageParams; - xPromptMessage, xOpenNewInstanceMessage: string; - xFiles: TStringList; -begin - xResult := isaStartNewInstance; - xPromptMessage := ''; - xOpenNewInstanceMessage := ''; - if Assigned(FChooseActionEvent) then - begin - xFiles := TStringList.Create; - try - TIDEInstances.AddFilesFromParams(aInParams, xFiles); - FChooseActionEvent(xFiles, xResult, xPromptMessage, xOpenNewInstanceMessage); - finally - xFiles.Free; - end; - end; - - SetLength(xParams, 3); - xParams[0] := TIDEInstances.MessageParam(PARAM_RESULT, IntToStr(Ord(xResult))); - xParams[1] := TIDEInstances.MessageParam(PARAM_PROMPTMESSAGE, xPromptMessage); - xParams[2] := TIDEInstances.MessageParam(PARAM_OPENNEWINSTANCEMESSAGE, xOpenNewInstanceMessage); - SimpleResponse(aMsgID, RESPONSE_SHOWPROMPT, xParams); -end; - -procedure TMainServer.DoOpenFiles(const aMsgID: string; - const aInParams: TMessageParams); -var - xResult: TOpenFilesResult; - xHandleBringToFront: HWND; - xFiles: TStrings; - xParams: TMessageParams; -begin - xResult := ofrStartNewInstance; - xHandleBringToFront := 0; - if Assigned(FOpenFilesEvent) then - begin - xFiles := TStringList.Create; - try - TIDEInstances.AddFilesFromParams(aInParams, xFiles); - FOpenFilesEvent(xFiles, xResult, xHandleBringToFront); - finally - xFiles.Free; - end; - end; - - SetLength(xParams, 2); - xParams[0] := TIDEInstances.MessageParam(PARAM_RESULT, IntToStr(Ord(xResult))); - xParams[1] := TIDEInstances.MessageParam(PARAM_HANDLEBRINGTOFRONT, IntToStr(xHandleBringToFront)); - SimpleResponse(aMsgID, RESPONSE_STARTNEWINSTANCE, xParams); -end; - -procedure TMainServer.SimpleResponse(const aResponseToMsgID, - aResponseType: string; const aParams: array of TMessageParam); -var - xStream: TMemoryStream; -begin - xStream := TMemoryStream.Create; - try - TIDEInstances.BuildMessage(aResponseType, aParams, xStream); - xStream.Position := 0; - PostResponse(aResponseToMsgID, MESSAGETYPE_XML, xStream); - finally - xStream.Free; - end; -end; - -procedure TMainServer.DoCheckMessages; -var - xMessageType: string; - xParams: TMessageParams; - xMsgID: string; - xMsgType: Integer; -begin - if Active then - begin - if PeekRequest(FMsgStream, xMsgID{%H-}, xMsgType{%H-}) and - (xMsgType = MESSAGETYPE_XML) then - begin - if TIDEInstances.ParseMessage(FMsgStream, xMessageType, xParams) and - (xMessageType = MESSAGE_CHOOSEACTION) - then - DoChooseActionEvent(xMsgID, xParams) - else - if xMessageType = MESSAGE_OPENFILES then - DoOpenFiles(xMsgID, xParams); - end; - end; -end; - -initialization - FLazIDEInstances := TIDEInstances.Create; - FLazIDEInstances.InitIDEInstances; - -finalization - FreeAndNil(FLazIDEInstances); - -end.