/
gps-main.adb
3163 lines (2674 loc) · 116 KB
/
gps-main.adb
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
------------------------------------------------------------------------------
-- GNAT Studio --
-- --
-- Copyright (C) 2001-2019, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for more details. You should have received a copy of the GNU --
-- General Public License distributed with this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with System;
with Interfaces.C.Strings;
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Interfaces.C; use Interfaces.C;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNATCOLL.Arg_Lists; use GNATCOLL.Arg_Lists;
with GNATCOLL.Scripts; use GNATCOLL.Scripts;
with GNAT.Strings;
with GNATCOLL.Memory;
with GNATCOLL.Projects; use GNATCOLL.Projects;
with GNATCOLL.Scripts.Python;
with GNATCOLL.Traces; use GNATCOLL.Traces;
with GNATCOLL.Utils; use GNATCOLL.Utils;
with GNATCOLL.VFS; use GNATCOLL.VFS;
with GNATCOLL.VFS_Utils; use GNATCOLL.VFS_Utils;
with Glib;
with Glib.Application; use Glib.Application;
with Glib.Error; use Glib.Error;
with Glib.Main;
with Glib.Messages; use Glib.Messages;
with Glib.Object; use Glib.Object;
with Glib.Option; use Glib.Option;
with Glib.Properties; use Glib.Properties;
with Glib.Utils;
with Gdk.Main;
with Gdk.Pixbuf; use Gdk.Pixbuf;
with Gdk.Window;
with Gtk; use Gtk;
with Gtk.Application; use Gtk.Application;
with Gtk.Enums; use Gtk.Enums;
with Gtk.Icon_Theme; use Gtk.Icon_Theme;
with Gtk.Image; use Gtk.Image;
with Gtk.Handlers;
with Gtk.Main;
with Gtk.Style_Provider; use Gtk.Style_Provider;
with Gtk.Widget; use Gtk.Widget;
with Gtk.Window; use Gtk.Window;
with Gtk_Utils; use Gtk_Utils;
with Fontconfig; use Fontconfig;
with Gtkada.Application; use Gtkada.Application;
with Gtkada.Bindings; use Gtkada.Bindings;
with Gtkada.Dialogs; use Gtkada.Dialogs;
with Gtkada.Intl;
with Gtkada.MDI; use Gtkada.MDI;
with Gtkada.Style;
with Gtkada.Types; use Gtkada.Types;
with Config; use Config;
with Default_Preferences; use Default_Preferences;
with Default_Preferences.Assistants; use Default_Preferences.Assistants;
with GPS.Callbacks; use GPS.Callbacks;
with GPS.Environments; use GPS.Environments;
with GPS.Intl; use GPS.Intl;
with GPS.Kernel; use GPS.Kernel;
with GPS.Kernel.Actions; use GPS.Kernel.Actions;
with GPS.Kernel.Clipboard; use GPS.Kernel.Clipboard;
with GPS.Kernel.Console; use GPS.Kernel.Console;
with GPS.Kernel.Contexts; use GPS.Kernel.Contexts;
with GPS.Kernel.Custom; use GPS.Kernel.Custom;
with GPS.Kernel.Custom.GUI; use GPS.Kernel.Custom.GUI;
with GPS.Kernel.Entities; use GPS.Kernel.Entities;
with GPS.Kernel.Hooks; use GPS.Kernel.Hooks;
with GPS.Kernel.MDI; use GPS.Kernel.MDI;
with GPS.Kernel.Messages; use GPS.Kernel.Messages;
with GPS.Kernel.Messages.Shell;
with GPS.Kernel.Modules; use GPS.Kernel.Modules;
with GPS.Kernel.Modules.UI; use GPS.Kernel.Modules.UI;
with GPS.Kernel.Preferences; use GPS.Kernel.Preferences;
with GPS.Kernel.Preferences_Views; use GPS.Kernel.Preferences_Views;
with GPS.Kernel.Project; use GPS.Kernel.Project;
with GPS.Kernel.Remote;
with GPS.Kernel.Scripts; use GPS.Kernel.Scripts;
with GPS.Kernel.Scripts.Hooks;
with GPS.Kernel.Style_Manager.Shell;
with GPS.Kernel.Task_Manager; use GPS.Kernel.Task_Manager;
with GPS.Kernel.Xref;
with GPS.Stock_Icons;
with GPS.Main_Window; use GPS.Main_Window;
with GPS.Menu;
with GPS.Search.GUI;
with GUI_Utils; use GUI_Utils;
with OS_Utils; use OS_Utils;
with Projects; use Projects;
with Project_Templates.GPS; use Project_Templates.GPS;
with Remote; use Remote;
with Src_Editor_Box; use Src_Editor_Box;
with String_Utils;
with Welcome_Dialogs; use Welcome_Dialogs;
with Welcome_View; use Welcome_View;
-- Modules registered by GPS
with Ada_Module;
with Aliases_Module;
with Bookmark_Views;
with Browsers.Call_Graph;
with Browsers.Canvas;
with Browsers.Dependency_Items;
with Browsers.Elaborations;
with Browsers.Entities;
with Browsers.Scripts;
with Browsers.Projects;
with Revision_Views;
with Buffer_Views;
with Builder_Module;
with Builder_Facility_Module;
with Call_Graph_Views;
with Casing_Exceptions;
with Clipboard_Views;
with Code_Analysis_Module;
with CodePeer.Module;
with Codefix_Module;
with Command_Window;
with Cpp_Module;
with Custom_Module;
with GNAThub.Module;
with GNAThub.Module.Shell;
with External_Editor_Module;
with GNATTest_Module;
with GPS.Location_View;
with GVD_Module;
with GVD.Assembly_View;
with GVD.Breakpoints;
with GVD.Breakpoints_List;
with GVD.Call_Stack;
with GVD.Dialogs;
with GVD.Memory_View;
with GVD.Preferences;
with GVD.Variables.View;
with GVD.Registers_View;
with Help_Module;
with KeyManager_Module;
with KeyManager_Module.Macros;
with Toolchains_Module;
with Ada_Semantic_Tree_Module;
with LAL.Module;
with Language_Handlers.Assistants;
with Learn.Views;
with Log_File_Views;
with GPS.LSP_Module;
with Memory_Usage_Views.Module;
with Navigation_Module;
with Outline_View;
with Project_Explorers;
with Project_Explorers_Files;
with Project_Properties;
with Project_Viewers;
with Python_Module;
with Refactoring_Module;
with Remote.Rsync;
with Remote_Module;
with Scenario_Views;
with Shell_Script;
with Socket_Module;
with Src_Editor_Module;
with Switches_Chooser.Scripts;
with Toolchains_Editor;
with VCS2.Module;
with VFS_Module;
with Vdiff2_Module;
with Vsearch;
with Language.Libclang;
with Ada_Semantic_Tree.Lang;
with GPS.Traces;
with GPS.Valgrind;
with Serial_Ports_Views;
procedure GPS.Main is
package ICS renames Interfaces.C.Strings;
use type ICS.chars_ptr;
use type Glib.Gint;
Me : constant Trace_Handle := Create ("GPS.MAIN.GPS");
Pid_Image : constant String := String_Utils.Image (Get_Process_Id);
Gtk_Errors : constant Trace_Handle := Create ("GPS.MAIN.GTK");
Memory_Monitor : Boolean;
Memory_Stack_Depth : constant := 3;
-- Stack depth for GNATCOLL.Memory
Refactor_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Refactor", GNATCOLL.Traces.On);
Python_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Python", GNATCOLL.Traces.On);
Call_Graph_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Call_Graph", GNATCOLL.Traces.On);
Dependency_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Dependency", GNATCOLL.Traces.On);
Project_Browser_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Project_Browser", GNATCOLL.Traces.On);
Browsers_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Browsers", GNATCOLL.Traces.On);
Entities_Browser_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Entities_Browser", GNATCOLL.Traces.On);
Revision_Views_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Revision_Views", GNATCOLL.Traces.On);
Aliases_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Aliases", GNATCOLL.Traces.On);
Project_Explorer_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Project_Explorer", GNATCOLL.Traces.On);
Files_Explorer_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Files_Explorer", GNATCOLL.Traces.On);
VCS2_Trace : constant Trace_Handle :=
Create ("GPS.VCS.MODULE", GNATCOLL.Traces.On);
External_Editor_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_External_Editor", GNATCOLL.Traces.On);
Custom_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Custom", GNATCOLL.Traces.On);
Project_Templates_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Project_Templates", GNATCOLL.Traces.On);
Code_Analysis_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Code_Analysis", GNATCOLL.Traces.On);
GNAThub_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_GNAThub", GNATCOLL.Traces.On);
CodePeer_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_CodePeer", GNATCOLL.Traces.On);
Codefix_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Codefix", GNATCOLL.Traces.On);
Builder_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Builder", GNATCOLL.Traces.On);
GVD_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_GVD", GNATCOLL.Traces.On);
GNATTest_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_GNATTest", GNATCOLL.Traces.On);
Startup_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Startup", GNATCOLL.Traces.On);
VFS_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_VFS", GNATCOLL.Traces.On);
Help_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Help", GNATCOLL.Traces.On);
Scenario_View_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_SCENARIO", GNATCOLL.Traces.On);
Project_Viewer_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Project_Viewer", GNATCOLL.Traces.On);
Project_Properties_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Project_Properties", GNATCOLL.Traces.On);
CPP_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_CPP", GNATCOLL.Traces.On);
Outline_View_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Outline", GNATCOLL.Traces.On);
Call_Graph_View_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Call_Graph_View", GNATCOLL.Traces.On);
Clipboard_View_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Clipboard_Vview", GNATCOLL.Traces.On);
Toolchains_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Toolchains", GNATCOLL.Traces.On);
Toolchains_Editor_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Toolchains_Editor", GNATCOLL.Traces.On);
Elaboration_Browser_Trace : constant Trace_Handle :=
Create ("GPS.INTERNAL.MODULE_Elaboration_Browser", GNATCOLL.Traces.On);
Debugger_GDB_Trace : constant Trace_Handle :=
Create ("MODULE.Debugger_GDB", GNATCOLL.Traces.Off);
Debugger_GDB_Pretty_Printer_Trace : constant Trace_Handle :=
Create ("MODULE.Debugger_GDB_Pretty_Printer", GNATCOLL.Traces.Off);
-- for testing gvd with pretty printer on
Debugger_GDB_MI_Trace : constant Trace_Handle :=
Create ("MODULE.Debugger_GDB_MI", GNATCOLL.Traces.Off);
Debugger_LLDB_Trace : constant Trace_Handle :=
Create ("MODULE.Debugger_LLDB", GNATCOLL.Traces.Off);
-- If any of these debug handles is active, the correponding module
-- is loaded.
subtype String_Access is GNAT.Strings.String_Access;
type File_To_Open is record
File : Unbounded_String;
Line : Natural := 1;
From_Project : Boolean := False;
end record;
package File_To_Open_Vectors is new Ada.Containers.Vectors
(Positive, File_To_Open);
type Config_File_Setup is record
Autoconf : Boolean := False;
Config_File : GNATCOLL.VFS.Virtual_File := GNATCOLL.VFS.No_File;
DB_Dirs : GNATCOLL.VFS.File_Array_Access;
end record;
Config_Files : Config_File_Setup;
Build_Tree_Dir : Virtual_File := No_File;
Root_Dir : Virtual_File := No_File;
Home_Dir : Virtual_File;
Prefix_Dir : Virtual_File;
GNATStudio_Home_Dir : Virtual_File;
GPS_Log_Dir : Virtual_File;
Show_Preferences_Assistant : Boolean := False;
Batch_File : String_Access;
Batch_Script : String_Access;
Hide_GPS : Boolean := False;
Tools_Host : String_Access;
Target : String_Access;
Protocol : String_Access;
Debugger_Name : String_Access;
Startup_Dir : String_Access;
Passed_Project_Name : String_Access;
Program_Args : String_Access;
Server_Mode : Boolean := False;
Ignore_Saved_Values : Boolean := False;
Port_Number : Natural := 0;
GPS_Main : GPS_Window;
Project_Name : Virtual_File := No_File;
Splash : Gtk_Window;
Files_To_Open : File_To_Open_Vectors.Vector;
Unexpected_Exception : Boolean := False;
Env : GPS.Environments.Environment;
Timeout_Id : Glib.Main.G_Source_Id;
pragma Unreferenced (Timeout_Id);
function Local_Command_Line
(Self : System.Address;
Arguments : access chars_ptr_array_access;
Exit_Status : access Glib.Gint) return Glib.Gboolean;
pragma Convention (C, Local_Command_Line);
-- override gtk+ builtin virtual method for an application.
-- This makes sure that we can do our own handling of --help
procedure Application_Class_Init (Self : GObject_Class);
pragma Convention (C, Application_Class_Init);
Application_Class_Record : aliased Glib.Object.Ada_GObject_Class;
-- A custom child of GtkApplication
procedure Startup_Callback
(Application : access Gapplication_Record'Class);
-- Handler for the ::startup signal, emitted by the application
procedure Activate_Callback
(Application : access Gapplication_Record'Class);
-- Handler for the ::activate signal, emitted by the application
function On_GPS_Started return Boolean;
-- Called when GPS is started and visible on the screen
function Command_Line_Callback
(Application : access Gapplication_Record'Class;
Command_Line : not null access Gapplication_Command_Line_Record'Class)
return Glib.Gint;
-- Handler for the ::command-line signal, emitted by the application
procedure Initialize_Environment_Variables;
-- Sanitize, sets and take into account various environment variables, and
-- initialize GPS according to them.
procedure Initialize_Low_Level (Status_Code : out Glib.Gint);
-- Initializes the low-level gtk, python, traces layers
-- This needs to be performed after environment variable initialisation.
type GPS_Option_Context is record
Context : Glib.Option.Goption_Context;
Do_Exit : Boolean := False;
-- Set to True if GPS should exit after parsing command line switches
Line : Positive := 1;
-- Line to use when opening files from the command line.
end record;
GPS_Command_Line : GPS_Option_Context;
-- Handling of command line
procedure Build_Command_Line;
-- Initialize the variable GPS_Command_Line.
function On_Switch
(Option_Name : ICS.chars_ptr;
Value : ICS.chars_ptr;
Data : System.Address; -- ignored
Error : access Glib.Error.GError) return Glib.Gboolean;
pragma Convention (C, On_Switch);
-- General callback for switch handling from GApplication
function On_File_Switch
(Option_Name : ICS.chars_ptr;
Value : ICS.chars_ptr;
Data : System.Address;
Error : access Glib.Error.GError) return Glib.Gboolean;
pragma Convention (C, On_File_Switch);
-- General callback for file opening handling from GApplication
procedure Handle_X_Switch (Val : String);
-- Handles the -X command line switch
procedure File_Open_Callback
(Application : Gtkada.Application.Gtkada_Application;
Files : Gtkada.Application.GFile_Array);
-- Handler for the ::open signal, emitted by the application
procedure Shutdown_Callback
(Application : access Gapplication_Record'Class);
procedure Set_Project_Name;
-- Set the project name from the command line switch
procedure Error_Message (Message : String; Save : Boolean);
-- Display the "Fatal error" message
procedure Display_Splash_Screen;
-- Display the GPS splash screen
procedure Load_CSS;
-- Load the GPS global and local CSS files
function Finish_Setup return Boolean;
-- Finish the set up of GPS, while the main loop is running
procedure Execute_Batch (Batch : String; As_File : Boolean);
-- Execute a batch command (either loading the file Batch if As_File is
-- true, or as a standard command otherwise).
procedure Default_Gtk_Mer
(Occurrence : Ada.Exceptions.Exception_Occurrence);
-- Called when an Ada callback raises an exception, to log it.
procedure Load_Fonts (Kernel : Kernel_Handle);
-- Load the fonts that ship by default with GPS
procedure Trace_With_Python_Backtrace
(Handle : not null access GNATCOLL.Traces.Trace_Handle_Record'Class;
E : Ada.Exceptions.Exception_Occurrence);
-- Trace unexpected exception with Python backtrace when available.
---------------------------------
-- Trace_With_Python_Backtrace --
---------------------------------
procedure Trace_With_Python_Backtrace
(Handle : not null access GNATCOLL.Traces.Trace_Handle_Record'Class;
E : Ada.Exceptions.Exception_Occurrence)
is
PBT : constant String := GNATCOLL.Scripts.Python.Python_Backtrace;
begin
if PBT /= "" then
Trace
(Handle,
E,
"Unexpected exception: Python backtrace: " & ASCII.LF & PBT);
else
Trace (Handle, E, "Unexpected exception: ");
end if;
end Trace_With_Python_Backtrace;
--------------------------------------
-- Initialize_Environment_Variables --
--------------------------------------
procedure Initialize_Environment_Variables is
function Getenv (Var : String) return String;
-- Get the environment variable for Var. If it's empty, return
-- the environment variable for Fallback_Var if it's not "".
function Get_Cwd return String;
-- proxies for the services in the command line, usable even when no
-- command line is passed
procedure Each_Environment_Variable (Name, Value : String);
-- If Name is a special environment variable, then store its preserved
-- and actual values into Env object.
function Getenv (Var : String) return String is
Str : String_Access := GNAT.OS_Lib.Getenv (Var);
begin
return S : constant String := Str.all do
Free (Str);
end return;
end Getenv;
function Get_Cwd return String is
begin
return Get_Current_Dir.Display_Full_Name;
end Get_Cwd;
procedure Each_Environment_Variable (Name, Value : String) is
Prefix : constant String := "GPS_STARTUP_";
begin
if Starts_With (Name, Prefix) then
declare
Unprefixed_Name : constant String :=
Name (Name'First + Prefix'Length .. Name'Last);
begin
Env.Append
(Name => Unprefixed_Name,
Users_Value => Value,
GPS_Value => Getenv (Unprefixed_Name));
end;
elsif not Env.Has_Element (Name) then
Env.Append
(Name => Name,
Users_Value => Value,
GPS_Value => Value);
end if;
end Each_Environment_Variable;
begin
-- Reset the environment that was set before GPS was started (since
-- starting GPS will generally imply a change in LD_LIBRARY_PATH to
-- point to the right libraries
declare
Tmp : constant String := Getenv ("GPS_STARTUP_LD_LIBRARY_PATH");
begin
if Tmp /= "" then
Setenv ("LD_LIBRARY_PATH", Tmp);
end if;
end;
declare
Tmp : constant String := Getenv ("GPS_STARTUP_DYLD_LIBRARY_PATH");
begin
if Tmp /= "" then
Setenv ("DYLD_LIBRARY_PATH", Tmp);
end if;
end;
declare
Tmp : constant String :=
Getenv ("GPS_STARTUP_DYLD_FALLBACK_LIBRARY_PATH");
begin
if Tmp /= "" then
Setenv ("DYLD_FALLBACK_LIBRARY_PATH", Tmp);
end if;
end;
declare
Charset : constant String := Getenv ("CHARSET");
begin
if Charset = "" then
-- Gtk+ does not like if CHARSET is not defined.
-- Need to set CHARSET *before* calling Gtk.Main.Init, so cannot
-- use Get_Pref here.
Setenv ("CHARSET", Config.Default_Charset);
end if;
end;
Startup_Dir := new String'(Get_Cwd);
-- Set the TERM variable to a dummy value, since we only know how to
-- handle simple terminals
Setenv ("TERM", "dumb");
declare
Home : constant String := Getenv_With_Fallback
("GNATSTUDIO_HOME", "GPS_HOME");
begin
if Home /= "" then
Home_Dir := Create (+Home);
Make_Dir (Home_Dir);
else
Home_Dir := Get_Home_Directory;
end if;
-- Under Windows, when the user directory contains international
-- characters, the value contained in the environment might not
-- be encoded in the same way as the filesystem. Add a safety check
-- for this.
if not Home_Dir.Is_Directory then
declare
As_UTF8 : constant Glib.UTF8_String :=
Glib.Utils.Get_Home_Dir;
Tmp : constant Virtual_File := Create (+(As_UTF8));
begin
if Tmp.Is_Directory then
-- $HOME/$USERPROFILE does not exist but its UTF8
-- representation exists; this is a safer bet for home
-- directory: use it.
Home_Dir := Tmp;
end if;
end;
end if;
end;
GNATStudio_Home_Dir := Create_From_Dir (Home_Dir, ".gnatstudio");
GPS_Log_Dir := Create_From_Dir (GNATStudio_Home_Dir, "log");
Ensure_Directory (GNATStudio_Home_Dir);
declare
Prefix : constant String := Getenv ("GPS_ROOT");
begin
if Prefix /= "" then
Prefix_Dir := Create (+Prefix);
end if;
end;
if Prefix_Dir = No_File then
declare
Prefix : constant String := Executable_Location;
begin
-- Check whether we are running the installed gps, or locally from
-- the development environment.
if Prefix'Length < 4
or else Prefix (Prefix'Last - 3 .. Prefix'Last - 1) /= "obj"
then
Prefix_Dir := Create (+Prefix);
else
Prefix_Dir := Create (+Config.Prefix);
end if;
end;
end if;
-- Load EDITION.txt file to add to version information
declare
Edition_File : constant Virtual_File :=
Create_From_Dir (Prefix_Dir, "share/gnatstudio/EDITION.txt");
Content : String_Access;
begin
if Edition_File.Is_Readable then
Content := Edition_File.Read_File;
Config.Version := Content.all & ' ' & Config.Version;
Free (Content);
end if;
exception
when others =>
null;
end;
declare
Tmp : constant String := Getenv ("PATH");
Prefix : constant String := Prefix_Dir.Display_Full_Name;
Bin : constant String :=
Prefix &
(if Prefix (Prefix'Last) /= Directory_Separator
then (1 => Directory_Separator) else "") &
"bin";
begin
if Tmp /= "" then
Setenv ("PATH", Tmp & Path_Separator & Bin);
else
Setenv
("PATH",
Ada.Environment_Variables.Value ("PATH")
& Path_Separator & Bin);
end if;
exception
-- Value may raise Constraint_Error if PATH is not set, nothing
-- to do in this case
when Constraint_Error => null;
end;
-- Python startup path
declare
Python_Path : constant String := Getenv ("PYTHONPATH");
New_Val : String_Access;
begin
if Python_Path = "" then
New_Val := new String'
(+Create_From_Dir
(Prefix_Dir, "share/gnatstudio/python").Full_Name);
else
New_Val := new String'
(+To_Path
(From_Path (+Python_Path) &
(1 => Create_From_Dir
(Prefix_Dir, "share/gnatstudio/python"))));
end if;
Setenv ("PYTHONPATH", New_Val.all);
Trace (Me, "PYTHONPATH=" & New_Val.all);
Free (New_Val);
end;
Env := new Environment_Record;
Ada.Environment_Variables.Iterate (Each_Environment_Variable'Access);
end Initialize_Environment_Variables;
--------------------------
-- Initialize_Low_Level --
--------------------------
procedure Initialize_Low_Level (Status_Code : out Glib.Gint) is
Ignored : Log_Handler_Id;
pragma Unreferenced (Ignored);
begin
Gtkada.Intl.Setlocale;
Gtkada.Intl.Bind_Text_Domain
("gps", +Create_From_Dir (Prefix_Dir, "share/locale").Full_Name);
Gtkada.Intl.Text_Domain ("gps");
-- Redirect all default Gtk+ logs to our own trace mechanism
Ignored := Log_Set_Handler
("", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("GLib", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("GLib-GObject", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("Pango", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("Atk", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("GdkPixbuf", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("Gdk", Log_Level_Mask, Gtk_Log'Access);
Ignored := Log_Set_Handler
("Gtk", Log_Level_Mask, Gtk_Log'Access);
declare
Plug_Ins : constant Virtual_File :=
Create_From_Dir (GNATStudio_Home_Dir, "plug-ins");
Themes : constant Virtual_File :=
Create_From_Dir (GNATStudio_Home_Dir, "themes");
Gnatinspect_Traces : constant Virtual_File :=
Create_From_Dir (GNATStudio_Home_Dir, "gnatinspect_traces.cfg");
File : Writable_File;
begin
if not Is_Directory (GNATStudio_Home_Dir) then
-- If the GNAT Studio home dir is not found, check if there is an
-- old GPS home dir: if yes, import it by copy. Otherwise display
-- the preferences assistant.
declare
Old_GPS_Home_Dir : constant Virtual_File := Create_From_Dir
(Home_Dir, ".gps");
Has_GNATStudio_Home_Dir : Boolean := False;
begin
if Is_Directory (Old_GPS_Home_Dir) then
Old_GPS_Home_Dir.Copy
(Target_Name => GNATStudio_Home_Dir.Full_Name,
Success => Has_GNATStudio_Home_Dir);
-- If we have found an old GPS home dir, rename the old
-- keys6.xml file to keys.xml file.
if Has_GNATStudio_Home_Dir then
declare
Old_Keys_File : constant Virtual_File :=
Create_From_Dir
(GNATStudio_Home_Dir,
+"keys6.xml");
Success : Boolean;
begin
if Old_Keys_File.Is_Regular_File then
Old_Keys_File.Rename
(Full_Name => Create_From_Dir
(GNATStudio_Home_Dir, +"keys.xml"),
Success => Success);
end if;
end;
end if;
end if;
if not Has_GNATStudio_Home_Dir then
Show_Preferences_Assistant := True;
Make_Dir (GNATStudio_Home_Dir);
end if;
end;
end if;
declare
Success : Boolean;
begin
if not Is_Directory (GPS_Log_Dir) then
-- A safety check: a previous version of GPS could have left
-- a regular file $HOME/.gnatstudio/log.
if Is_Regular_File (GPS_Log_Dir) then
GNATCOLL.VFS.Delete (GPS_Log_Dir, Success);
-- Another safety: on bad filesystems, deletion isn't always
-- instantaneous - it's a very rare case and should not
-- occur regularly, so use a delay here.
delay 1.0;
end if;
Make_Dir (GPS_Log_Dir);
end if;
exception
when VFS_Directory_Error =>
Put_Line (Standard_Error,
(-"Cannot create logs directory ") &
GPS_Log_Dir.Display_Full_Name & ASCII.LF);
Status_Code := 1;
return;
end;
-- Setup the GPS traces configuration
GPS.Traces.Setup_Traces_Config
(GNATStudio_Home_Dir => GNATStudio_Home_Dir);
if not Gnatinspect_Traces.Is_Regular_File then
-- Make sure gnatinspect will never try to write to stdout. This
-- works around an issue in gnatcoll-traces, where handles that
-- are enabled by default would write to stdout in no config file
-- is parsed to override this.
File := Gnatinspect_Traces.Write_File;
Write (File, ">log_gnatinspect");
Close (File);
end if;
if not Is_Directory (Plug_Ins) then
Make_Dir (Plug_Ins);
end if;
if not Is_Directory (Themes) then
Make_Dir (Themes);
end if;
exception
when VFS_Directory_Error =>
Put_Line (Standard_Error,
(-"Cannot create config directory ") &
GNATStudio_Home_Dir.Display_Full_Name & ASCII.LF);
Status_Code := 1;
return;
end;
declare
Tmp : constant Virtual_File := Get_Tmp_Directory;
begin
if not Is_Directory (Tmp) then
Put_Line (Standard_Error,
(-"Cannot access temporary directory ") &
Tmp.Display_Full_Name);
Status_Code := 1;
return;
end if;
end;
-- Initialize the traces
declare
File : constant Virtual_File :=
Create_From_Dir (GNATStudio_Home_Dir, "traces.cfg");
begin
GNATCOLL.Traces.Parse_Config_File
(Filename => No_File,
Default => File,
On_Exception => GNATCOLL.Traces.Deactivate);
exception
when others =>
Put_Line (Standard_Error,
(-"Cannot parse file ") & File.Display_Full_Name);
Status_Code := 1;
return;
end;
-- Create the traces file for the Ada Language Server. Do this
-- after initializing the GPS traces, since the contents depends
-- on the testsuite trace.
declare
ALS_Traces : constant Virtual_File :=
Create_From_Dir (GNATStudio_Home_Dir, "ada_ls_traces.cfg");
File : Writable_File;
begin
if not ALS_Traces.Is_Regular_File then
File := ALS_Traces.Write_File;
if Active (Testsuite_Handle) then
-- In testsuite mode, create the ALS log traces with
-- the full contents by default.
Write
(File,
">log/ada_ls_log.$T.txt:buffer_size=0:buffer_size=0"
& "ALS.MAIN=yes" & ASCII.LF
& "ALS.IN=yes" & ASCII.LF
& "ALS.OUT=yes" & ASCII.LF);
else
Write
(File,
">log/ada_ls_log.$T.txt:buffer_size=0:buffer_size=0"
& ASCII.LF
& "ALS.MAIN=yes" & ASCII.LF
& ASCII.LF
& "## uncomment the following 2 lines"
& " to activate full traces" & ASCII.LF
& "#ALS.IN=yes" & ASCII.LF
& "#ALS.OUT=yes" & ASCII.LF);
end if;
Close (File);
end if;
end;
-- Check whether we should enable memory monitor. We do not use a
-- constant for the trace_handle, since we must create it only after
-- the call to Add_Trace_Decorators.
Memory_Monitor := Active (Create ("DEBUG.ADA_MEMORY", Off));
GNATCOLL.Memory.Configure
(Activate_Monitor => Memory_Monitor,
Stack_Trace_Depth => Memory_Stack_Depth,
Disable_Free => False);
Trace (Me, "GPS " & To_String (Config.Version) & " ("
& Config.Source_Date & ") hosted on " & Config.Target);
Trace (Me, "Gtk+ static version: "
& String_Utils.Image (Integer (Gtk.Major_Version)) & '.'
& String_Utils.Image (Integer (Gtk.Minor_Version)) & '.'
& String_Utils.Image (Integer (Gtk.Micro_Version)));
Trace (Me, "Gtk+ dynamic version: "
& String_Utils.Image (Gtk_Major_Version) & '.'
& String_Utils.Image (Gtk_Minor_Version) & '.'
& String_Utils.Image (Gtk_Micro_Version));
Status_Code := 0;
end Initialize_Low_Level;
---------------------
-- Handle_X_Switch --
---------------------
procedure Handle_X_Switch (Val : String) is
Idx : constant Integer := Ada.Strings.Fixed.Index (Val, "=");
begin
if Idx >= Val'First then
Ada.Environment_Variables.Set
(Name => Val (Val'First .. Idx - 1),
Value => Val (Idx + 1 .. Val'Last));
else
Put_Line ("Invalid value for -X, should be VAR=VALUE");
GPS_Command_Line.Do_Exit := True;
end if;
end Handle_X_Switch;
---------------
-- On_Switch --
---------------
function On_Switch
(Option_Name : ICS.chars_ptr;
Value : ICS.chars_ptr;
Data : System.Address;
Error : access Glib.Error.GError) return Glib.Gboolean
is
pragma Unreferenced (Data, Error);
Switch : constant String := ICS.Value (Option_Name);
begin
-- Make sure that we don't display the preferences assistant when GPS
-- is invoked with some switches: it might bother advanced users.
Show_Preferences_Assistant := False;
if Switch = "--project" or else Switch = "-P" then
-- Although this isn't costly, we must not resolve symbolic
-- links for project names unless Fast Project Loading mode is
-- disabled. Some users (IA27-014) and SCM have local links
-- that point to a SCM cache directory (Rational Synergy), but
-- directory names are still local. These users should use
-- Trusted mode so that we do not resolve symbolic links
Passed_Project_Name := new String'(ICS.Value (Value));
elsif Switch = "--help"
or else Switch = "-h"
or else Switch = "--help-all"
then
declare
-- Get_Help (False) will also print options that are not
-- in the main group (such as Gtk+ options)
-- Get_Help (True) will only print options from the main
-- group
Help : constant String :=
"GNAT Studio " & To_String (Config.Version) & " ("
& Config.Source_Date & ") hosted on "