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
|
------------------------------------------------------------------------------
-- G P S --
-- --
-- Copyright (C) 2003-2018, 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. --
------------------------------------------------------------------------------
package body GPS.Scripts.Commands is
procedure Free_When_Python_Owns_Ada (S : in out Scheduled_Command_Access);
-- Free a command, when it was owned by script instances.
procedure Free_When_Python_Owns_Ada
(S : in out Scheduled_Command_Access) is
begin
Unref (Command_Access (S));
end Free_When_Python_Owns_Ada;
package Command_Script_Proxies is new Script_Proxies
(Scheduled_Command_Access, Command_Script_Proxy,
Free => Free_When_Python_Owns_Ada);
procedure Command_Cmds
(Data : in out Callback_Data'Class; Command : String);
-- Handle shell commands.
function Create_Dead_Command
(Self : Scheduled_Command_Access) return Scheduled_Command_Access;
function Transfer_Ownership is new Command_Script_Proxies.Transfer_Ownership
(Detach => Create_Dead_Command);
-- Transfer ownership of the command to the script instances associated
-- with it (if any), instead of having the script instances belong to
-- the command.
-----------------
-- Get_Command --
-----------------
function Get_Command
(Data : Callback_Data'Class;
Nth : Positive;
Allow_Null : Boolean := False)
return Scheduled_Command_Access is
begin
return Command_Script_Proxies.From_Instance
(Data.Nth_Arg (Nth, Allow_Null => Allow_Null));
exception
when No_Data_Set_For_Instance =>
return null;
end Get_Command;
-----------------
-- Set_Command --
-----------------
procedure Set_Command
(Inst : Class_Instance;
Command : not null access Scheduled_Command'Class) is
begin
Command_Script_Proxies.Store_In_Instance
(Command.Instances, Inst, Scheduled_Command_Access (Command));
end Set_Command;
------------------
-- Get_Instance --
------------------
function Get_Instance
(Command : not null access Scheduled_Command'Class;
Script : not null access Scripting_Language_Record'Class;
Class_To_Create : String := "")
return Class_Instance
is
begin
return Command_Script_Proxies.Get_Or_Create_Instance
(Command.Instances, Scheduled_Command_Access (Command), Script,
Class_To_Create => Class_To_Create);
end Get_Instance;
------------------
-- Command_Cmds --
------------------
procedure Command_Cmds
(Data : in out Callback_Data'Class; Command : String)
is
Cmd : Scheduled_Command_Access;
begin
if Command = "progress" then
Cmd := Get_Command (Data, 1);
if Cmd /= null then
Data.Set_Return_Value (Progress (Cmd).Current);
Data.Set_Return_Value_Key ("current");
Data.Set_Return_Value (Progress (Cmd).Total);
Data.Set_Return_Value_Key ("total");
end if;
elsif Command = "name" then
Cmd := Get_Command (Data, 1);
if Cmd /= null then
Data.Set_Return_Value (Name (Cmd));
end if;
elsif Command = "get_result" then
Data.Set_Return_Value
(String'
("Error: this primitive should be implemented by subclasses"));
end if;
end Command_Cmds;
-----------------
-- Get_Command --
-----------------
function Get_Command (Command : access Scheduled_Command'Class)
return Command_Access is
begin
return Command.Command;
end Get_Command;
-------------
-- Execute --
-------------
overriding function Execute
(Command : access Scheduled_Command) return Command_Return_Type is
begin
return Execute (Command.Command);
end Execute;
----------
-- Name --
----------
overriding function Name
(Command : access Scheduled_Command) return String is
begin
return Name (Command.Command);
end Name;
--------------
-- Progress --
--------------
overriding function Progress
(Command : access Scheduled_Command) return Progress_Record is
begin
return Progress (Command.Command);
end Progress;
------------------
-- Set_Progress --
------------------
overriding procedure Set_Progress (Command : access Scheduled_Command;
Progress : Progress_Record) is
begin
Set_Progress (Command.Command, Progress);
end Set_Progress;
---------------
-- Interrupt --
---------------
overriding procedure Interrupt (Command : in out Scheduled_Command) is
begin
Interrupt (Command.Command.all);
end Interrupt;
-------------------------
-- Create_Dead_Command --
-------------------------
function Create_Dead_Command
(Self : Scheduled_Command_Access) return Scheduled_Command_Access
is
Result : constant Scheduled_Command_Access := new Scheduled_Command;
begin
Result.Command := Self.Command;
Self.Command := null;
-- Some commands (like a GPS.Kernel.Timeout.Monitor_Command) keep a
-- reference to the scheduled command they are encapsulated in. This
-- pointer should thus be reset.
return Result;
end Create_Dead_Command;
--------------------
-- Primitive_Free --
--------------------
overriding procedure Primitive_Free (Command : in out Scheduled_Command) is
begin
-- If some script instance is referencing the command, we need to
-- keep it in memory, but owned by the instances.
if Transfer_Ownership (Command.Instances) = Has_No_Instances then
Unref (Command.Command);
end if;
end Primitive_Free;
----------
-- Undo --
----------
overriding function Undo (This : access Scheduled_Command) return Boolean is
begin
return Undo (This.Command);
end Undo;
--------------------
-- Create_Wrapper --
--------------------
function Create_Wrapper
(Command : access Root_Command'Class)
return Scheduled_Command_Access
is
C : Scheduled_Command_Access;
begin
if Command.all in Scheduled_Command'Class then
C := Scheduled_Command_Access (Command);
return C;
end if;
C := new Scheduled_Command;
C.Command := Command_Access (Command);
return C;
end Create_Wrapper;
-----------------------
-- Register_Commands --
-----------------------
procedure Register_Commands
(Kernel : access GPS.Core_Kernels.Core_Kernel_Record'Class)
is
Command_Class : constant Class_Type :=
Kernel.Scripts.New_Class (Command_Class_Name);
begin
Kernel.Scripts.Register_Command
("progress", Handler => Command_Cmds'Access, Class => Command_Class);
Kernel.Scripts.Register_Command
("name", Handler => Command_Cmds'Access, Class => Command_Class);
Kernel.Scripts.Register_Command
("get_result", Handler => Command_Cmds'Access, Class => Command_Class);
end Register_Commands;
end GPS.Scripts.Commands;
|
