← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to ide/ideguicmdline.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
ide/ideguicmdline.pas
 
1
{
 
2
 /***************************************************************************
 
3
                              idecmdline.pas
 
4
                             --------------------
 
5
               A unit to manage command lines issue used inside the ide
 
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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
 
25
 *                                                                         *
 
26
 ***************************************************************************
 
27
 
 
28
 Author: Mattias Gaertner
 
29
 
 
30
  This unit manages the command line parameters for lazarus and startlazarus,
 
31
  but not lazbuild.
 
32
}
 
33
unit IDEGuiCmdLine;
 
34
 
 
35
{$mode objfpc}{$H+}
 
36
 
 
37
interface
 
38
 
 
39
uses
 
40
  Classes, SysUtils, FileUtil, lazutf8classes, LazConf, LCLProc,
 
41
  LazarusIDEStrConsts, IDECmdLine;
 
42
 
 
43
procedure ParseGuiCmdLineParams(var SkipAutoLoadingLastProject,
 
44
                                      StartedByStartLazarus,
 
45
                                      EnableRemoteControl,
 
46
                                      ShowSplashScreen,
 
47
                                      Setup: Boolean);
 
48
 
 
49
// remote control
 
50
const
 
51
  EnableRemoteControlOpt='--remote-control';
 
52
var
 
53
  EnableRemoteControl: boolean = false;
 
54
 
 
55
function SetupMainIDEInstance: boolean; // false if this is a secondary instance
 
56
function GetPidFile: string;
 
57
function IsLazarusPIDRunning(aPID: int64): boolean;
 
58
function GetRemoteControlFilename: string;
 
59
procedure CleanUpPIDFile;
 
60
 
 
61
implementation
 
62
 
 
63
{$IFDEF Linux}
 
64
{$DEFINE UseProcFileSystem}
 
65
{$ENDIF}
 
66
{$IF defined(FreeBSD) and defined(VER2_5)}
 
67
{$DEFINE UseFreeBSDKernProc}
 
68
uses FreeBSD, BaseUnix;
 
69
{$ENDIF}
 
70
{$IFDEF LCLCarbon}
 
71
{$DEFINE UseCarbonProc}
 
72
uses MacOSAll, CarbonProc;
 
73
{$ENDIF}
 
74
 
 
75
function IsLazarusPIDRunning(aPID: int64): boolean;
 
76
 
 
77
  function CheckProcFileSystem: boolean;
 
78
  var
 
79
    sl: TStringList;
 
80
    Filename: String;
 
81
  begin
 
82
    Result:=false;
 
83
    Filename:='/proc/'+IntToStr(aPID)+'/cmdline';
 
84
    if not FileExists(Filename) then exit;
 
85
    sl:=TStringList.Create;
 
86
    try
 
87
      try
 
88
        sl.LoadFromFile(Filename);
 
89
        if sl.Count=0 then exit;
 
90
        if Pos('lazarus',lowercase(sl[0]))<1 then exit;
 
91
        Result:=true;
 
92
      except
 
93
      end;
 
94
    finally
 
95
      sl.Free;
 
96
    end;
 
97
  end;
 
98
 
 
99
  {$IFDEF UseFreeBSDKernProc}
 
100
  function CheckFreeBSDKernProc: boolean;
 
101
  var
 
102
    s: string;
 
103
  begin
 
104
    Result:=(kernproc_getpath(aPID,s)<>-1)
 
105
        and (Pos('lazarus',lowercase(s))>0);
 
106
  end;
 
107
  {$ENDIF}
 
108
 
 
109
  {$IFDEF UseCarbonProc}
 
110
  function CheckCarbonProc: boolean;
 
111
  var
 
112
    psn: ProcessSerialNumber;
 
113
    info: ProcessInfoRec;
 
114
    processName: CFStringRef;
 
115
    s: String;
 
116
  begin
 
117
    Result:=false;
 
118
    if GetProcessForPID(aPid,psn)<>noErr then exit;
 
119
    FillByte(info,SizeOf(info),0);
 
120
    if GetProcessInformation(psn,info)<>noErr then exit;
 
121
    processName := nil;
 
122
    if CopyProcessName(psn, processName)<>noErr then exit;
 
123
    if processName<>nil then begin
 
124
      s:=CFStringToStr(processName);
 
125
      CFRelease(processName);
 
126
      Result:=Pos('lazarus',lowercase(s))>0;
 
127
    end;
 
128
  end;
 
129
  {$ENDIF}
 
130
 
 
131
begin
 
132
  Result:=true;
 
133
  {$IFDEF UseFreeBSDKernProc}
 
134
  if CheckFreeBSDKernProc then exit;
 
135
  {$ENDIF}
 
136
  {$IFDEF UseProcFileSystem}
 
137
  if CheckProcFileSystem then exit;
 
138
  {$ENDIF}
 
139
  {$IFDEF UseCarbonProc}
 
140
  if CheckCarbonProc then exit;
 
141
  {$ENDIF}
 
142
  Result:=false;
 
143
end;
 
144
 
 
145
function GetPidFile: string;
 
146
begin
 
147
  Result:=AppendPathDelim(GetPrimaryConfigPath)+'pid.txt';
 
148
end;
 
149
 
 
150
procedure ParseGuiCmdLineParams(var SkipAutoLoadingLastProject,
 
151
  StartedByStartLazarus, EnableRemoteControl, ShowSplashScreen, Setup: Boolean);
 
152
var
 
153
  i: Integer;
 
154
begin
 
155
  ParseNoGuiCmdLineParams;
 
156
  for i:= 1 to ParamCount do
 
157
  begin
 
158
    //DebugLn(['ParseGuiCmdLineParams ',i,' "',ParamStrUTF8(i),'"']);
 
159
    if ParamIsOption(i, NoSplashScreenOptLong) or
 
160
        ParamIsOption(i, NoSplashScreenOptShort)    then
 
161
      ShowSplashScreen := false
 
162
    else if ParamIsOption(i, ShowSetupDialogOptLong) then
 
163
      Setup:=true
 
164
    else if ParamIsOption(i, SkipLastProjectOpt) then
 
165
      SkipAutoLoadingLastProject := true
 
166
    else if ParamIsOption(i, StartedByStartLazarusOpt) then
 
167
      StartedByStartLazarus := true
 
168
    else if ParamIsOption(i, EnableRemoteControlOpt) then
 
169
      EnableRemoteControl := true;
 
170
  end;
 
171
end;
 
172
 
 
173
function SetupMainIDEInstance: boolean;
 
174
 
 
175
  procedure WritePIDFile(const Filename: string; aPID: int64);
 
176
  var
 
177
    Dir: String;
 
178
    sl: TStringListUTF8;
 
179
  begin
 
180
    debugln(['WritePIDFile File="',Filename,'" PID=',aPID]);
 
181
    sl:=TStringListUTF8.Create;
 
182
    try
 
183
      sl.Add(IntToStr(aPID));
 
184
      try
 
185
        Dir:=ChompPathDelim(ExtractFilePath(Filename));
 
186
        if not DirectoryExistsUTF8(Dir) then begin
 
187
          if not CreateDirUTF8(Dir) then
 
188
            debugln(['WritePIDFile failed to create directory ',Dir]);
 
189
          exit;
 
190
        end;
 
191
        sl.SaveToFile(Filename);
 
192
      except
 
193
        on E: Exception do begin
 
194
          debugln(['WritePIDFile "',Filename,'" failed:']);
 
195
          debugln(E.Message);
 
196
        end;
 
197
      end;
 
198
    finally
 
199
      sl.Free;
 
200
    end;
 
201
  end;
 
202
 
 
203
  function ReadPIDFile(const Filename: string; out ConfigPID: int64): boolean;
 
204
  var
 
205
    sl: TStringListUTF8;
 
206
  begin
 
207
    Result:=false;
 
208
    ConfigPID:=-1;
 
209
    debugln(['ReadPIDFile ',Filename]);
 
210
    if not FileExistsUTF8(Filename) then exit;
 
211
    sl:=TStringListUTF8.Create;
 
212
    try
 
213
      try
 
214
        sl.LoadFromFile(Filename);
 
215
        ConfigPID:=StrToInt64(sl[0]);
 
216
        Result:=true;
 
217
        debugln(['ReadPIDFile ConfigPID=',ConfigPID]);
 
218
      except
 
219
        on E: Exception do begin
 
220
          debugln(['ReadPIDFile "',Filename,'" failed:']);
 
221
          debugln(E.Message);
 
222
        end;
 
223
      end;
 
224
    finally
 
225
      sl.Free;
 
226
    end;
 
227
  end;
 
228
 
 
229
  procedure SendCmdlineActionsToMainInstance;
 
230
  var
 
231
    sl: TStringListUTF8;
 
232
    Param: String;
 
233
    Filename: String;
 
234
    i: Integer;
 
235
  begin
 
236
    sl:=TStringListUTF8.Create;
 
237
    try
 
238
      sl.Add('Show');
 
239
      for i:=1 to Paramcount do begin
 
240
        Param:=ParamStrUTF8(i);
 
241
        if (Param='') or (Param[1]='-') then continue;
 
242
        sl.Add('Open '+Param);
 
243
      end;
 
244
      Filename:=GetRemoteControlFilename;
 
245
      try
 
246
        debugln(['SendCmdlineActionsToMainInstance Commands="',sl.Text,'"']);
 
247
        sl.SaveToFile(Filename);
 
248
      except
 
249
        on E: Exception do begin
 
250
          debugln(['SendCmdlineActionsToMainInstance failed to write ',Filename]);
 
251
          debugln(E.Message);
 
252
        end;
 
253
      end;
 
254
    finally
 
255
      sl.Free;
 
256
    end;
 
257
  end;
 
258
 
 
259
var
 
260
  PIDFilename: String;
 
261
  MyPID, ConfigPID: int64;
 
262
  PIDRead: Boolean;
 
263
begin
 
264
  Result:=true;
 
265
  if not EnableRemoteControl then exit;
 
266
 
 
267
  // check if another IDE (of this user and same configuration) is already
 
268
  // running. Request it to handle the show and handle the command line
 
269
  // parameters (e.g. open files). And if successful return false.
 
270
  // Otherwise become the main instance.
 
271
  PIDFilename:=GetPidFile;
 
272
  MyPID:=GetProcessID;
 
273
  ConfigPID:=-1;
 
274
  PIDRead:=ReadPIDFile(PIDFilename,ConfigPID);
 
275
  if PIDRead and (ConfigPID<>MyPID) then begin
 
276
    // there is a pid file from another instance
 
277
    if not IsLazarusPIDRunning(ConfigPID) then begin
 
278
      // clean up
 
279
      DeleteFileUTF8(PIDFilename);
 
280
      PIDRead:=false;
 
281
    end;
 
282
  end;
 
283
  if not FileExistsUTF8(PIDFilename) then begin
 
284
    // try to become the main instance
 
285
    WritePIDFile(PIDFilename,MyPID);
 
286
    PIDRead:=false;
 
287
  end;
 
288
  if not PIDRead then
 
289
    PIDRead:=ReadPIDFile(PIDFilename,ConfigPID);
 
290
  if ConfigPID=MyPID then begin
 
291
    // this is the main instance
 
292
    exit;
 
293
  end;
 
294
  // this is a second instance
 
295
  Result:=false;
 
296
 
 
297
  SendCmdlineActionsToMainInstance;
 
298
end;
 
299
 
 
300
function GetRemoteControlFilename: string;
 
301
begin
 
302
  Result:=AppendPathDelim(GetPrimaryConfigPath)+'ideremotecontrol.txt';
 
303
end;
 
304
 
 
305
procedure CleanUpPIDFile;
 
306
begin
 
307
  if EnableRemoteControl then
 
308
    DeleteFileUTF8(GetRemoteControlFilename);
 
309
end;
 
310
 
 
311
end.
 
312