|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . C G I --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2001-2018, AdaCore --
|
|
111
|
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;
|
