GCC v8.2
[gcc.git] / gcc / ada / libgnat / g-cgi.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                             G N A T . C G I                              --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --                      Copyright (C) 2001-2018, AdaCore                    --
10 --                                                                          --
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.                                     --
17 --                                                                          --
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.               --
21 --                                                                          --
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/>.                                          --
26 --                                                                          --
27 -- GNAT was originally developed  by the GNAT team at  New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
29 --                                                                          --
30 ------------------------------------------------------------------------------
31
32 with Ada.Text_IO;
33 with Ada.Strings.Fixed;
34 with Ada.Characters.Handling;
35 with Ada.Strings.Maps;
36
37 with GNAT.OS_Lib;
38 with GNAT.Table;
39
40 package body GNAT.CGI is
41
42    use Ada;
43
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.
49
50    Current_Method : Method_Type;
51    --  This is the current method used to pass CGI parameters
52
53    Header_Sent : Boolean := False;
54    --  Will be set to True when the header will be sent
55
56    --  Key/Value table declaration
57
58    type String_Access is access String;
59
60    type Key_Value is record
61       Key   : String_Access;
62       Value : String_Access;
63    end record;
64
65    package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
66
67    -----------------------
68    -- Local subprograms --
69    -----------------------
70
71    procedure Check_Environment;
72    pragma Inline (Check_Environment);
73    --  This procedure will raise Data_Error if Valid_Environment is False
74
75    procedure Initialize;
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.
79
80    --------------------
81    -- Argument_Count --
82    --------------------
83
84    function Argument_Count return Natural is
85    begin
86       Check_Environment;
87       return Key_Value_Table.Last;
88    end Argument_Count;
89
90    -----------------------
91    -- Check_Environment --
92    -----------------------
93
94    procedure Check_Environment is
95    begin
96       if not Valid_Environment then
97          raise Data_Error;
98       end if;
99    end Check_Environment;
100
101    ------------
102    -- Decode --
103    ------------
104
105    function Decode (S : String) return String is
106       Result : String (S'Range);
107       K      : Positive := S'First;
108       J      : Positive := Result'First;
109
110    begin
111       while K <= S'Last loop
112          if K + 2 <= S'Last
113            and then S (K) = '%'
114            and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1))
115            and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2))
116          then
117             --  Here we have '%HH' which is an encoded character where 'HH' is
118             --  the character number in hexadecimal.
119
120             Result (J) := Character'Val
121               (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#'));
122             K := K + 3;
123
124          --  Plus sign is decoded as a space
125
126          elsif S (K) = '+' then
127             Result (J) := ' ';
128             K := K + 1;
129
130          else
131             Result (J) := S (K);
132             K := K + 1;
133          end if;
134
135          J := J + 1;
136       end loop;
137
138       return Result (Result'First .. J - 1);
139    end Decode;
140
141    -------------------------
142    -- For_Every_Parameter --
143    -------------------------
144
145    procedure For_Every_Parameter is
146       Quit : Boolean;
147
148    begin
149       Check_Environment;
150
151       for K in 1 .. Key_Value_Table.Last loop
152
153          Quit := False;
154
155          Action (Key_Value_Table.Table (K).Key.all,
156                  Key_Value_Table.Table (K).Value.all,
157                  K,
158                  Quit);
159
160          exit when Quit;
161
162       end loop;
163    end For_Every_Parameter;
164
165    ----------------
166    -- Initialize --
167    ----------------
168
169    procedure Initialize is
170
171       Request_Method : constant String :=
172                          Characters.Handling.To_Upper
173                            (Metavariable (CGI.Request_Method));
174
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.
178
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.
183
184       procedure Set_Parameter_Table (Data : String);
185       --  Parse the parameter data and set the parameter table
186
187       --------------------
188       -- Initialize_GET --
189       --------------------
190
191       procedure Initialize_GET is
192          Data : constant String := Metavariable (Query_String);
193       begin
194          Current_Method := Get;
195
196          if Data /= "" then
197             Set_Parameter_Table (Data);
198          end if;
199       end Initialize_GET;
200
201       ---------------------
202       -- Initialize_POST --
203       ---------------------
204
205       procedure Initialize_POST is
206          Content_Length : constant Natural :=
207                             Natural'Value (Metavariable (CGI.Content_Length));
208          Data : String (1 .. Content_Length);
209
210       begin
211          Current_Method := Post;
212
213          if Content_Length /= 0 then
214             Text_IO.Get (Data);
215             Set_Parameter_Table (Data);
216          end if;
217       end Initialize_POST;
218
219       -------------------------
220       -- Set_Parameter_Table --
221       -------------------------
222
223       procedure Set_Parameter_Table (Data : String) is
224
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".
228
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.
233
234          Index : Positive := Data'First;
235          Amp   : Natural;
236
237          -------------------
238          -- Add_Parameter --
239          -------------------
240
241          procedure Add_Parameter (K : Positive; P : String) is
242             Equal : constant Natural := Strings.Fixed.Index (P, "=");
243
244          begin
245             if Equal = 0 then
246                raise Data_Error;
247
248             else
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))));
252             end if;
253          end Add_Parameter;
254
255       --  Start of processing for Set_Parameter_Table
256
257       begin
258          Key_Value_Table.Set_Last (Count);
259
260          for K in 1 .. Count - 1 loop
261             Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
262
263             Add_Parameter (K, Data (Index .. Amp - 1));
264
265             Index := Amp + 1;
266          end loop;
267
268          --  add last parameter
269
270          Add_Parameter (Count, Data (Index .. Data'Last));
271       end Set_Parameter_Table;
272
273    --  Start of processing for Initialize
274
275    begin
276       if Request_Method = "GET" then
277          Initialize_GET;
278
279       elsif Request_Method = "POST" then
280          Initialize_POST;
281
282       else
283          Valid_Environment := False;
284       end if;
285
286    exception
287       when others =>
288
289          --  If we have an exception during initialization of this unit we
290          --  just declare it invalid.
291
292          Valid_Environment := False;
293    end Initialize;
294
295    ---------
296    -- Key --
297    ---------
298
299    function Key (Position : Positive) return String is
300    begin
301       Check_Environment;
302
303       if Position <= Key_Value_Table.Last then
304          return Key_Value_Table.Table (Position).Key.all;
305       else
306          raise Parameter_Not_Found;
307       end if;
308    end Key;
309
310    ----------------
311    -- Key_Exists --
312    ----------------
313
314    function Key_Exists (Key : String) return Boolean is
315    begin
316       Check_Environment;
317
318       for K in 1 .. Key_Value_Table.Last loop
319          if Key_Value_Table.Table (K).Key.all = Key then
320             return True;
321          end if;
322       end loop;
323
324       return False;
325    end Key_Exists;
326
327    ------------------
328    -- Metavariable --
329    ------------------
330
331    function Metavariable
332      (Name     : Metavariable_Name;
333       Required : Boolean := False) return String
334    is
335       function Get_Environment (Variable_Name : String) return String;
336       --  Returns the environment variable content
337
338       ---------------------
339       -- Get_Environment --
340       ---------------------
341
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;
345       begin
346          OS_Lib.Free (Value);
347          return Result;
348       end Get_Environment;
349
350       Result : constant String :=
351                  Get_Environment (Metavariable_Name'Image (Name));
352
353    --  Start of processing for Metavariable
354
355    begin
356       Check_Environment;
357
358       if Result = "" and then Required then
359          raise Parameter_Not_Found;
360       else
361          return Result;
362       end if;
363    end Metavariable;
364
365    -------------------------
366    -- Metavariable_Exists --
367    -------------------------
368
369    function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
370    begin
371       Check_Environment;
372
373       if Metavariable (Name) = "" then
374          return False;
375       else
376          return True;
377       end if;
378    end Metavariable_Exists;
379
380    ------------
381    -- Method --
382    ------------
383
384    function Method return Method_Type is
385    begin
386       Check_Environment;
387       return Current_Method;
388    end Method;
389
390    --------
391    -- Ok --
392    --------
393
394    function Ok return Boolean is
395    begin
396       return Valid_Environment;
397    end Ok;
398
399    ----------------
400    -- Put_Header --
401    ----------------
402
403    procedure Put_Header
404      (Header : String  := Default_Header;
405       Force  : Boolean := False)
406    is
407    begin
408       if Header_Sent = False or else Force then
409          Check_Environment;
410          Text_IO.Put_Line (Header);
411          Text_IO.New_Line;
412          Header_Sent := True;
413       end if;
414    end Put_Header;
415
416    ---------
417    -- URL --
418    ---------
419
420    function URL return String is
421
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).
425
426       -----------------------
427       -- Exists_And_Not_80 --
428       -----------------------
429
430       function Exists_And_Not_80 (Server_Port : String) return String is
431       begin
432          if Server_Port = "80" then
433             return "";
434          else
435             return ':' & Server_Port;
436          end if;
437       end Exists_And_Not_80;
438
439    --  Start of processing for URL
440
441    begin
442       Check_Environment;
443
444       return "http://"
445         & Metavariable (Server_Name)
446         & Exists_And_Not_80 (Metavariable (Server_Port))
447         & Metavariable (Script_Name);
448    end URL;
449
450    -----------
451    -- Value --
452    -----------
453
454    function Value
455      (Key      : String;
456       Required : Boolean := False)
457       return     String
458    is
459    begin
460       Check_Environment;
461
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;
465          end if;
466       end loop;
467
468       if Required then
469          raise Parameter_Not_Found;
470       else
471          return "";
472       end if;
473    end Value;
474
475    -----------
476    -- Value --
477    -----------
478
479    function Value (Position : Positive) return String is
480    begin
481       Check_Environment;
482
483       if Position <= Key_Value_Table.Last then
484          return Key_Value_Table.Table (Position).Value.all;
485       else
486          raise Parameter_Not_Found;
487       end if;
488    end Value;
489
490 begin
491
492    Initialize;
493
494 end GNAT.CGI;