1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2017, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
33 with Ada
.Strings
.Fixed
;
34 with Ada
.Characters
.Handling
;
35 with Ada
.Strings
.Maps
;
40 package body GNAT
.CGI
is
44 Valid_Environment
: Boolean := True;
45 -- This boolean will be set to False if the initialization was not
46 -- completed correctly. It must be set to true there because the
47 -- Initialize routine (called during elaboration) will use some of the
48 -- services exported by this unit.
50 Current_Method
: Method_Type
;
51 -- This is the current method used to pass CGI parameters
53 Header_Sent
: Boolean := False;
54 -- Will be set to True when the header will be sent
56 -- Key/Value table declaration
58 type String_Access
is access String;
60 type Key_Value
is record
62 Value
: String_Access
;
65 package Key_Value_Table
is new Table
(Key_Value
, Positive, 1, 1, 50);
67 -----------------------
68 -- Local subprograms --
69 -----------------------
71 procedure Check_Environment
;
72 pragma Inline
(Check_Environment
);
73 -- This procedure will raise Data_Error if Valid_Environment is False
76 -- Initialize CGI package by reading the runtime environment. This
77 -- procedure is called during elaboration. All exceptions raised during
78 -- this procedure are deferred.
84 function Argument_Count
return Natural is
87 return Key_Value_Table
.Last
;
90 -----------------------
91 -- Check_Environment --
92 -----------------------
94 procedure Check_Environment
is
96 if not Valid_Environment
then
99 end Check_Environment
;
105 function Decode
(S
: String) return String is
106 Result
: String (S
'Range);
107 K
: Positive := S
'First;
108 J
: Positive := Result
'First;
111 while K
<= S
'Last loop
114 and then Characters
.Handling
.Is_Hexadecimal_Digit
(S
(K
+ 1))
115 and then Characters
.Handling
.Is_Hexadecimal_Digit
(S
(K
+ 2))
117 -- Here we have '%HH' which is an encoded character where 'HH' is
118 -- the character number in hexadecimal.
120 Result
(J
) := Character'Val
121 (Natural'Value ("16#" & S
(K
+ 1 .. K
+ 2) & '#'));
124 -- Plus sign is decoded as a space
126 elsif S
(K
) = '+' then
138 return Result
(Result
'First .. J
- 1);
141 -------------------------
142 -- For_Every_Parameter --
143 -------------------------
145 procedure For_Every_Parameter
is
151 for K
in 1 .. Key_Value_Table
.Last
loop
155 Action
(Key_Value_Table
.Table
(K
).Key
.all,
156 Key_Value_Table
.Table
(K
).Value
.all,
163 end For_Every_Parameter
;
169 procedure Initialize
is
171 Request_Method
: constant String :=
172 Characters
.Handling
.To_Upper
173 (Metavariable
(CGI
.Request_Method
));
175 procedure Initialize_GET
;
176 -- Read CGI parameters for a GET method. In this case the parameters
177 -- are passed into QUERY_STRING environment variable.
179 procedure Initialize_POST
;
180 -- Read CGI parameters for a POST method. In this case the parameters
181 -- are passed with the standard input. The total number of characters
182 -- for the data is passed in CONTENT_LENGTH environment variable.
184 procedure Set_Parameter_Table
(Data
: String);
185 -- Parse the parameter data and set the parameter table
191 procedure Initialize_GET
is
192 Data
: constant String := Metavariable
(Query_String
);
194 Current_Method
:= Get
;
197 Set_Parameter_Table
(Data
);
201 ---------------------
202 -- Initialize_POST --
203 ---------------------
205 procedure Initialize_POST
is
206 Content_Length
: constant Natural :=
207 Natural'Value (Metavariable
(CGI
.Content_Length
));
208 Data
: String (1 .. Content_Length
);
211 Current_Method
:= Post
;
213 if Content_Length
/= 0 then
215 Set_Parameter_Table
(Data
);
219 -------------------------
220 -- Set_Parameter_Table --
221 -------------------------
223 procedure Set_Parameter_Table
(Data
: String) is
225 procedure Add_Parameter
(K
: Positive; P
: String);
226 -- Add a single parameter into the table at index K. The parameter
227 -- format is "key=value".
229 Count
: constant Positive :=
230 1 + Strings
.Fixed
.Count
(Data
, Strings
.Maps
.To_Set
("&"));
231 -- Count is the number of parameters in the string. Parameters are
232 -- separated by ampersand character.
234 Index
: Positive := Data
'First;
241 procedure Add_Parameter
(K
: Positive; P
: String) is
242 Equal
: constant Natural := Strings
.Fixed
.Index
(P
, "=");
249 Key_Value_Table
.Table
(K
) :=
250 Key_Value
'(new String'(Decode
(P
(P
'First .. Equal
- 1))),
251 new String'(Decode (P (Equal + 1 .. P'Last))));
255 -- Start of processing for Set_Parameter_Table
258 Key_Value_Table.Set_Last (Count);
260 for K in 1 .. Count - 1 loop
261 Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
263 Add_Parameter (K, Data (Index .. Amp - 1));
268 -- add last parameter
270 Add_Parameter (Count, Data (Index .. Data'Last));
271 end Set_Parameter_Table;
273 -- Start of processing for Initialize
276 if Request_Method = "GET" then
279 elsif Request_Method = "POST" then
283 Valid_Environment := False;
289 -- If we have an exception during initialization of this unit we
290 -- just declare it invalid.
292 Valid_Environment := False;
299 function Key (Position : Positive) return String is
303 if Position <= Key_Value_Table.Last then
304 return Key_Value_Table.Table (Position).Key.all;
306 raise Parameter_Not_Found;
314 function Key_Exists (Key : String) return Boolean is
318 for K in 1 .. Key_Value_Table.Last loop
319 if Key_Value_Table.Table (K).Key.all = Key then
331 function Metavariable
332 (Name : Metavariable_Name;
333 Required : Boolean := False) return String
335 function Get_Environment (Variable_Name : String) return String;
336 -- Returns the environment variable content
338 ---------------------
339 -- Get_Environment --
340 ---------------------
342 function Get_Environment (Variable_Name : String) return String is
343 Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
344 Result : constant String := Value.all;
350 Result : constant String :=
351 Get_Environment (Metavariable_Name'Image (Name));
353 -- Start of processing for Metavariable
358 if Result = "" and then Required then
359 raise Parameter_Not_Found;
365 -------------------------
366 -- Metavariable_Exists --
367 -------------------------
369 function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
373 if Metavariable (Name) = "" then
378 end Metavariable_Exists;
384 function Method return Method_Type is
387 return Current_Method;
394 function Ok return Boolean is
396 return Valid_Environment;
404 (Header : String := Default_Header;
405 Force : Boolean := False)
408 if Header_Sent = False or else Force then
410 Text_IO.Put_Line (Header);
420 function URL return String is
422 function Exists_And_Not_80 (Server_Port : String) return String;
423 -- Returns ':' & Server_Port if Server_Port is not "80" and the empty
424 -- string otherwise (80 is the default sever port).
426 -----------------------
427 -- Exists_And_Not_80 --
428 -----------------------
430 function Exists_And_Not_80 (Server_Port : String) return String is
432 if Server_Port = "80" then
435 return ':' & Server_Port;
437 end Exists_And_Not_80;
439 -- Start of processing for URL
445 & Metavariable (Server_Name)
446 & Exists_And_Not_80 (Metavariable (Server_Port))
447 & Metavariable (Script_Name);
456 Required : Boolean := False)
462 for K in 1 .. Key_Value_Table.Last loop
463 if Key_Value_Table.Table (K).Key.all = Key then
464 return Key_Value_Table.Table (K).Value.all;
469 raise Parameter_Not_Found;
479 function Value (Position : Positive) return String is
483 if Position <= Key_Value_Table.Last then
484 return Key_Value_Table.Table (Position).Value.all;
486 raise Parameter_Not_Found;