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 | ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2009-2019, AdaCore --
-- Copyright (C) 2020, Heisenbug Ltd. --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling;
package body GNATCOLL.Opt_Parse.Extension is
function "+" (Self : in String) return XString renames To_XString;
function "+" (Self : in XString) return String renames To_String;
function Parse_One_Option
(Short, Long : in String;
Args : in XString_Array;
Pos : in Positive;
New_Pos : out Parser_Return) return XString;
---------------------------------------------------------------------------
-- Parse_One_Option
---------------------------------------------------------------------------
function Parse_One_Option (Short : in String;
Long : in String;
Args : in XString_Array;
Pos : in Positive;
New_Pos : out Parser_Return) return XString is
begin
if
Args (Pos) = Long
or else (Short /= "" and then Args (Pos) = Short)
then
if Pos + 1 > Args'Last or else Args (Pos + 1).Starts_With ("-") then
-- No more arguments or already next option.
New_Pos := Pos + 1;
return Null_XString;
end if;
New_Pos := Pos + 2;
return Args (Pos + 1);
elsif Args (Pos).Starts_With (Long & "=") then
New_Pos := Pos + 1;
return Args (Pos).Slice (Long'Last + 2, Args (Pos).Length);
elsif Short /= "" and then Args (Pos).Starts_With (Short) then
New_Pos := Pos + 1;
return Args (Pos).Slice (Short'Last + 1, Args (Pos).Length);
else
New_Pos := Error_Return;
return +"";
end if;
end Parse_One_Option;
package body Parse_Option_With_Default is
type Option_Parser is new GNATCOLL.Opt_Parse.Parser_Type with
null record;
overriding
function Usage (Self : Option_Parser) return String is
("[" & Long & (if Short = "" then "" else "|" & Short) & " "
& Ada.Characters.Handling.To_Upper (Long (3 .. Long'Last)) & "]");
overriding
function Help_Name (Dummy : Option_Parser) return String is
(Long & ", " & Short);
overriding
function Parse_Args
(Self : in out Option_Parser;
Args : in XString_Array;
Pos : in Positive;
Result : in out Parsed_Arguments) return Parser_Return;
type Internal_Result is new Parser_Result with
record
Result : Arg_Type;
end record;
type Internal_Result_Access is access all Internal_Result;
overriding
procedure Release (Self : in out Internal_Result) is null;
Self_Val : aliased Option_Parser :=
Option_Parser'(Name => +Long (3 .. Long'Last),
Help => +Help,
Parser => Parser.Data,
Opt => True,
Position => <>);
Self : constant Parser_Access := Self_Val'Unchecked_Access;
------------------------------------------------------------------------
-- Get
------------------------------------------------------------------------
function Get
(Args : Parsed_Arguments := No_Parsed_Arguments) return Arg_Type is
begin
if not Enabled then
return Default_Val;
end if;
declare
R : constant Parser_Result_Access := Self.Get_Result (Args);
begin
if R /= null then
return Internal_Result (R.all).Result;
else
return Default_Val;
end if;
end;
end Get;
------------------------------------------------------------------------
-- Parse_Args
------------------------------------------------------------------------
overriding
function Parse_Args
(Self : in out Option_Parser;
Args : in XString_Array;
Pos : in Positive;
Result : in out Parsed_Arguments) return Parser_Return
is
New_Pos : Parser_Return;
Raw : constant XString :=
Parse_One_Option (Short, Long, Args, Pos, New_Pos);
begin
if New_Pos /= Error_Return then
declare
Res : constant Internal_Result_Access :=
new Internal_Result'(Start_Pos => Pos,
End_Pos => Pos,
Result => Convert (+Raw));
begin
Result.Ref.Get.Results (Self.Position) :=
Res.all'Unchecked_Access;
end;
end if;
return New_Pos;
end Parse_Args;
begin
if Enabled then
Parser.Data.Opts_Parsers.Append (Self);
Parser.Data.All_Parsers.Append (Self);
Self.Position := Parser.Data.All_Parsers.Last_Index;
end if;
end Parse_Option_With_Default;
end GNATCOLL.Opt_Parse.Extension;
|