Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/g-cgi.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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-2017, 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; |