← Back to branch summary

~ubuntu-branches/debian/sid/adabrowse/sid

« back to all changes in this revision

Viewing changes to ad-html.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2004-02-14 13:22:40 UTC
  • Revision ID: james.westby@ubuntu.com-20040214132240-cqumhiq1677pkvzo
Tags: upstream-4.0.2
Import upstream version 4.0.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
ad-html.adb
 
1
-------------------------------------------------------------------------------
 
2
--
 
3
--  This file is part of AdaBrowse.
 
4
--
 
5
-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG>
 
6
-- <BLOCKQUOTE>
 
7
--    AdaBrowse is free software; you can redistribute it and/or modify it
 
8
--    under the terms of the  GNU General Public License as published by the
 
9
--    Free Software  Foundation; either version 2, or (at your option) any
 
10
--    later version. AdaBrowse is distributed in the hope that it will be
 
11
--    useful, but <EM>without any warranty</EM>; without even the implied
 
12
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
 
13
--    See the GNU General Public License for  more details. You should have
 
14
--    received a copy of the GNU General Public License with this distribution,
 
15
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
 
16
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 
17
--    USA.
 
18
-- </BLOCKQUOTE>
 
19
--
 
20
-- <DL><DT><STRONG>
 
21
-- Author:</STRONG><DD>
 
22
--   Thomas Wolf  (TW)
 
23
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
 
24
--
 
25
-- <DL><DT><STRONG>
 
26
-- Purpose:</STRONG><DD>
 
27
--   HTML output helper routines.</DL>
 
28
--
 
29
-- <!--
 
30
-- Revision History
 
31
--
 
32
--   02-FEB-2002   TW  First release.
 
33
--   04-FEB-2002   TW  Added 'Get_Compile_Command' for V1.01.
 
34
--   13-MAR-2002   TW  Added 'Header' and 'Footer' with file parameter.
 
35
--                     Also added key 'Index_XRef'.
 
36
--   14-MAR-2002   TW  Added key 'Index_Title'.
 
37
--   18-MAR-2002   TW  Correction in HTMLize: only replace & by &amp; if it
 
38
--                     isn't already the start of a named character entity
 
39
--                     (e.g., if the original comment is "&lt;", we *don't*
 
40
--                     want to replace the '&', and the same goes for "&#34;").
 
41
--                        Also changed HTMLize_Comment to replace pairs of '@'
 
42
--                     without white-space in between by <CODE> and </CODE>.
 
43
--   03-APR-2002   TW  Moved all items for indices to package AD.Indices.
 
44
--   18-JUN-2002   TW  Removed a bunch of unused operations.
 
45
--   24-JUn-2002   TW  Changed 'Is_Named_Char' to also handle numeric character
 
46
--                     entities in hexadecimal format ("&#xE5;" or &#XE5;").
 
47
--   04-JUL-2002   TW  Changed the 'Header' and 'Footer' routines by factoring
 
48
--                     their bodies into generic procedures such that there's
 
49
--                     only one place in the sources where these string occur,
 
50
--                     not two. Also added a "STYLE" element to the header.
 
51
--   07-JUL-2003   TW  Added a new "UL.index" style to the STYLE element in the
 
52
--                     header.
 
53
-- -->
 
54
-------------------------------------------------------------------------------
 
55
 
 
56
pragma License (GPL);
 
57
 
 
58
with Ada.Characters.Handling;
 
59
with Ada.Calendar;
 
60
with Ada.Strings.Fixed;
 
61
with Ada.Strings.Maps;
 
62
with Ada.Strings.Unbounded;
 
63
with Ada.Text_IO;
 
64
 
 
65
with AD.Config;
 
66
with AD.Version;
 
67
 
 
68
with Util.Calendar.IO;
 
69
 
 
70
with Util.Strings;
 
71
 
 
72
package body AD.HTML is
 
73
 
 
74
   package ASF renames Ada.Strings.Fixed;
 
75
   package ASM renames Ada.Strings.Maps;
 
76
   package ASU renames Ada.Strings.Unbounded;
 
77
 
 
78
   use Util.Strings;
 
79
 
 
80
   type HTML_Tag is array (HTML_Tag_Kind) of ASU.Unbounded_String;
 
81
 
 
82
   Style_Sheet : ASU.Unbounded_String;
 
83
 
 
84
   Body_Start  : ASU.Unbounded_String;
 
85
 
 
86
   Char_Set    : ASU.Unbounded_String;
 
87
 
 
88
   Title       : HTML_Tag;
 
89
   Sub_Title   : HTML_Tag;
 
90
   Keyword     : HTML_Tag;
 
91
   Attribute   : HTML_Tag;
 
92
   Definition  : HTML_Tag;
 
93
   Comment     : HTML_Tag;
 
94
   Literal     : HTML_Tag;
 
95
   Ending      : HTML_Tag;
 
96
 
 
97
   function Character_Set
 
98
     return String
 
99
   is
 
100
   begin
 
101
      return ASU.To_String (Char_Set);
 
102
   end Character_Set;
 
103
 
 
104
   generic
 
105
      with procedure Line (S : in String);
 
106
   procedure Dump_Header
 
107
     (Title : in String);
 
108
 
 
109
   procedure Dump_Header
 
110
     (Title : in String)
 
111
   is
 
112
   begin
 
113
      Line
 
114
        ("<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">");
 
115
      Line ("");
 
116
      Line ("<HTML>");
 
117
      Line ("");
 
118
      Line ("<HEAD>");
 
119
      Line ("<TITLE>" & HTMLize (Title) & "</TITLE>");
 
120
      Line ("<META NAME=""generator"" CONTENT=""AdaBrowse " &
 
121
            AD.Version.Get_Version & ' ' & AD.Version.Get_URL & """>");
 
122
      if ASU.Length (Char_Set) /= 0 then
 
123
         Line ("<META http-equiv=""Content-Type"" content=""" &
 
124
               "text/html; charset=" & ASU.To_String (Char_Set) & """>");
 
125
      end if;
 
126
      Line ("<LINK REV=""made"" HREF=""" & AD.Version.Get_URL & """>");
 
127
      --  Now put the default styles here. They can be overwritten by a user-
 
128
      --  defined style sheet containing !important rules.
 
129
      Line ("<STYLE TYPE=""text/css"">");
 
130
      Line ("  TABLE.title  { background-color : #99CCFF }");
 
131
      Line ("  TABLE.footer { background-color : #99CCFF }");
 
132
      Line ("  TD.type { background-color : #CCEEFF }");
 
133
      Line ("  TD.odd { background-color : #99CCFF }");
 
134
      Line ("  TD.even { background-color : #CCEEFF }");
 
135
      Line ("  TD.code { background-color : #EEEEEE }");
 
136
      Line ("  SPAN.comment { color : red }");
 
137
      Line ("  SPAN.literal { color : green }");
 
138
      Line ("  SPAN.definition { color : purple }");
 
139
      Line ("  H3.subtitle  { background-color : #CCEEFF }");
 
140
      Line ("  UL.index { list-style: none }");
 
141
      Line ("</STYLE>");
 
142
      declare
 
143
         S : constant String := ASU.To_String (Style_Sheet);
 
144
      begin
 
145
         if S'Last >= S'First then
 
146
            Line ("<LINK REL=""stylesheet"" HREF=""" & S &
 
147
                  """ TYPE=""text/css"">");
 
148
         end if;
 
149
      end;
 
150
      Line ("</HEAD>");
 
151
      Line ("");
 
152
      Line (ASU.To_String (Body_Start));
 
153
      Line ("");
 
154
      Line (ASU.To_String (AD.HTML.Title (Before)) & HTMLize (Title) &
 
155
            ASU.To_String (AD.HTML.Title (After)));
 
156
      Line ("");
 
157
      Line ("<!-- Generated by AdaBrowse " & AD.Version.Get_Version &
 
158
            ' ' & AD.Version.Get_URL & " -->");
 
159
   end Dump_Header;
 
160
 
 
161
   procedure Header
 
162
     (File  : in Ada.Text_IO.File_Type;
 
163
      Title : in String)
 
164
   is
 
165
      procedure Write_Line
 
166
        (S : in String)
 
167
      is
 
168
      begin
 
169
         Ada.Text_IO.Put_Line (File, S);
 
170
      end Write_Line;
 
171
 
 
172
      procedure Dump is new Dump_Header (Write_Line);
 
173
 
 
174
   begin
 
175
      Dump (Title);
 
176
   end Header;
 
177
 
 
178
   generic
 
179
      with procedure Write (S : in String);
 
180
      with procedure Line  (S : in String);
 
181
   procedure Dump_Footer;
 
182
 
 
183
   procedure Dump_Footer
 
184
   is
 
185
      T          : constant Ada.Calendar.Time := Ada.Calendar.Clock;
 
186
      Debug_Mode : constant Boolean :=
 
187
        False;
 
188
   begin
 
189
      --  Make sure we're no longer in an HTML comment!
 
190
      Write ("<!-- -->" &
 
191
             ASU.To_String (Ending (Before)) & "<!-- -->" &
 
192
             "Generated");
 
193
      if not Debug_Mode then
 
194
         Write
 
195
            (" on " & Util.Calendar.IO.Image (T) &
 
196
             " at " & Util.Calendar.IO.Image (Ada.Calendar.Seconds (T)));
 
197
      end if;
 
198
      Write (" by <A HREF=""" & AD.Version.Get_URL & """ TARGET=""_top""" &
 
199
             ">AdaBrowse " & AD.Version.Get_Version & "</A>");
 
200
      if not Debug_Mode then
 
201
         if AD.Config.Get_Nof_Config_Files = 1 then
 
202
            Write (" using configuration file " &
 
203
                   HTMLize (AD.Config.Get_Config_Files));
 
204
         elsif AD.Config.Get_Nof_Config_Files > 1 then
 
205
            Write (" using configuration files " &
 
206
                   HTMLize (AD.Config.Get_Config_Files));
 
207
         end if;
 
208
      end if;
 
209
      Line ('.' & ASU.To_String (Ending (After)));
 
210
      Line ("</BODY>");
 
211
      Line ("</HTML>");
 
212
   end Dump_Footer;
 
213
 
 
214
   procedure Footer
 
215
     (File : in Ada.Text_IO.File_Type)
 
216
   is
 
217
      procedure Write
 
218
        (S : in String)
 
219
      is
 
220
      begin
 
221
         Ada.Text_IO.Put (File, S);
 
222
      end Write;
 
223
 
 
224
      procedure Write_Line
 
225
        (S : in String)
 
226
      is
 
227
      begin
 
228
         Ada.Text_IO.Put_Line (File, S);
 
229
      end Write_Line;
 
230
 
 
231
      procedure Dump is new Dump_Footer (Write, Write_Line);
 
232
 
 
233
   begin
 
234
      Dump;
 
235
   end Footer;
 
236
 
 
237
   procedure Subtitle
 
238
     (File : in Ada.Text_IO.File_Type;
 
239
      Text : in String)
 
240
   is
 
241
   begin
 
242
      Ada.Text_IO.Put_Line
 
243
        (File,
 
244
         ASU.To_String (Sub_Title (Before)) &
 
245
         HTMLize (Text) &
 
246
         ASU.To_String (Sub_Title (After)));
 
247
   end Subtitle;
 
248
 
 
249
   ----------------------------------------------------------------------------
 
250
 
 
251
   HTML_Special_Chars : constant ASM.Character_Set :=
 
252
     ASM.To_Set ("&<>""");
 
253
   Is_8_Bit           : constant ASM.Character_Set :=
 
254
     ASM.To_Set (ASM.Character_Range'(Low  => Character'Val (160),
 
255
                                      High => Character'Last));
 
256
 
 
257
   subtype Var_String_Length is Natural range 0 .. 6;
 
258
 
 
259
   type Variable_String (N : Var_String_Length := 0) is
 
260
      record
 
261
         S : String (1 .. N);
 
262
      end record;
 
263
 
 
264
   type Replacement_Table is array (Character) of Variable_String;
 
265
 
 
266
   Replacement : constant Replacement_Table :=
 
267
     ('&' => (5, "&amp;"),
 
268
      '"' => (6, "&quot;"),
 
269
      '<' => (4, "&lt;"),
 
270
      '>' => (4, "&gt;"),
 
271
      others => (0, ""));
 
272
 
 
273
   function Get_Replacement
 
274
     (Ch : in Character)
 
275
     return String
 
276
   is
 
277
   begin
 
278
      if Replacement (Ch).N > 0 then
 
279
         return Replacement (Ch).S;
 
280
      else
 
281
         return "&#" & Trim (Natural'Image (Character'Pos (Ch))) & ';';
 
282
      end if;
 
283
   end Get_Replacement;
 
284
 
 
285
   function Is_Named_Char
 
286
     (S : in String)
 
287
     return Boolean
 
288
   is
 
289
   begin
 
290
      if S'Last < S'First then return False; end if;
 
291
      if S (S'First) = '#' then
 
292
         declare
 
293
            Start : Natural;
 
294
            I     : Natural := S'First + 1;
 
295
         begin
 
296
            if I <= S'Last and then (S (I) = 'x' or else S (I) = 'X') then
 
297
               --  Hex number
 
298
               I := I + 1; Start := I;
 
299
               while I <= S'Last and then
 
300
                     Ada.Characters.Handling.Is_Hexadecimal_Digit (S (I))
 
301
               loop
 
302
                  I := I + 1;
 
303
               end loop;
 
304
            else
 
305
               --  Decimal number
 
306
               Start := I;
 
307
               while I <= S'Last and then
 
308
                     Ada.Characters.Handling.Is_Decimal_Digit (S (I))
 
309
               loop
 
310
                  I := I + 1;
 
311
               end loop;
 
312
            end if;
 
313
            return I > Start and then I > S'Last;
 
314
         end;
 
315
      else
 
316
         declare
 
317
            I : Natural := S'First;
 
318
         begin
 
319
            while I <= S'Last and then Is_In (Letters, S (I)) loop
 
320
               I := I + 1;
 
321
            end loop;
 
322
            return I > S'Last;
 
323
         end;
 
324
      end if;
 
325
   end Is_Named_Char;
 
326
 
 
327
   function HTMLize
 
328
     (S             : in String;
 
329
      Keep_Entities : in Boolean := True)
 
330
     return String
 
331
   is
 
332
      use ASM;
 
333
      I : constant Natural := ASF.Index (S, HTML_Special_Chars or Is_8_Bit);
 
334
   begin
 
335
      if I = 0 then return S; end if;
 
336
      declare
 
337
         R : constant String := Get_Replacement (S (I));
 
338
      begin
 
339
         if S (I) = '&' and then Keep_Entities then
 
340
            --  Crap. What if we already have "&lt;" or "&#34;" in the source?
 
341
            declare
 
342
               J : constant Natural := First_Index (S (I + 1 .. S'Last), ';');
 
343
            begin
 
344
               if J > I + 1 and then
 
345
                  --  Check that we have either: # followed by decimal digits,
 
346
                  --  # followed by 'x' or 'X' and hex digits, or sequence of
 
347
                  --  letters.
 
348
                  Is_Named_Char (S (I + 1 .. J - 1))
 
349
               then
 
350
                  return S (S'First .. J) &
 
351
                         HTMLize (S (J + 1 .. S'Last), Keep_Entities);
 
352
               end if;
 
353
            end;
 
354
         end if;
 
355
         if I = S'First then
 
356
            return R & HTMLize (S (I + 1 .. S'Last), Keep_Entities);
 
357
         else
 
358
            return S (S'First .. I - 1) & R &
 
359
                   HTMLize (S (I + 1 .. S'Last), Keep_Entities);
 
360
         end if;
 
361
      end;
 
362
   end HTMLize;
 
363
 
 
364
   function Find_Tag_End
 
365
     (S      : in String;
 
366
      Is_End : in Boolean := False)
 
367
     return Natural
 
368
   is
 
369
      I : Natural := S'First;
 
370
   begin
 
371
      if Is_End then
 
372
         --  Scan ahead to the next '>'.
 
373
         I := First_Index (S, '>');
 
374
      else
 
375
         declare
 
376
            In_String : Boolean   := False;
 
377
            Delim     : Character := ' ';
 
378
         begin
 
379
            while I <= S'Last loop
 
380
               if In_String and then S (I) = Delim then
 
381
                  In_String := False;
 
382
               elsif not In_String then
 
383
                  Delim := S (I);
 
384
                  if Delim = '"' or else Delim = ''' then
 
385
                     In_String := True;
 
386
                  else
 
387
                     exit when Delim = '>';
 
388
                  end if;
 
389
               end if;
 
390
               I := I + 1;
 
391
            end loop;
 
392
         end;
 
393
         if I > S'Last then I := 0; end if;
 
394
      end if;
 
395
      return I;
 
396
   end Find_Tag_End;
 
397
 
 
398
   ----------------------------------------------------------------------------
 
399
 
 
400
   function Attributes
 
401
     (Source : in String)
 
402
     return String
 
403
   is
 
404
      I : Natural := Next_Non_Blank (Source);
 
405
   begin
 
406
      if I = 0 then return ""; end if;
 
407
      declare
 
408
         Result : String (I .. Source'Last);
 
409
         J      : Natural := Result'First - 1;
 
410
      begin
 
411
         --  Replace all LFs or TABs by a space.
 
412
         while I <= Source'Last loop
 
413
            J := J + 1;
 
414
            if Is_In (Blanks, Source (I)) then
 
415
               Result (J) := ' ';
 
416
            else
 
417
               Result (J) := Source (I);
 
418
            end if;
 
419
            I := I + 1;
 
420
         end loop;
 
421
         --  Strip trailing white space:
 
422
         while J >= Result'First and then Result (J) = ' ' loop
 
423
            J := J - 1;
 
424
         end loop;
 
425
         return Result (Result'First .. J);
 
426
      end;
 
427
   end Attributes;
 
428
 
 
429
   ----------------------------------------------------------------------------
 
430
 
 
431
   function Get_Keyword
 
432
     (What : in HTML_Tag_Kind)
 
433
     return String
 
434
   is
 
435
   begin
 
436
      return ASU.To_String (Keyword (What));
 
437
   end Get_Keyword;
 
438
 
 
439
   function Get_Attribute
 
440
     (What : in HTML_Tag_Kind)
 
441
     return String
 
442
   is
 
443
   begin
 
444
      return ASU.To_String (Attribute (What));
 
445
   end Get_Attribute;
 
446
 
 
447
   function Get_Definition
 
448
     (What : in HTML_Tag_Kind)
 
449
     return String
 
450
   is
 
451
   begin
 
452
      return ASU.To_String (Definition (What));
 
453
   end Get_Definition;
 
454
 
 
455
   function Get_Comment
 
456
     (What : in HTML_Tag_Kind)
 
457
     return String
 
458
   is
 
459
   begin
 
460
      return ASU.To_String (Comment (What));
 
461
   end Get_Comment;
 
462
 
 
463
   function Get_Literal
 
464
     (What : in HTML_Tag_Kind)
 
465
     return String
 
466
   is
 
467
   begin
 
468
      return ASU.To_String (Literal (What));
 
469
   end Get_Literal;
 
470
 
 
471
   ----------------------------------------------------------------------------
 
472
 
 
473
   procedure Set_Char_Set
 
474
     (Id : in String)
 
475
   is
 
476
   begin
 
477
      Char_Set := ASU.To_Unbounded_String (Id);
 
478
   end Set_Char_Set;
 
479
 
 
480
   procedure Set_Style_Sheet
 
481
     (URL : in String)
 
482
   is
 
483
   begin
 
484
      Style_Sheet := ASU.To_Unbounded_String (URL);
 
485
   end Set_Style_Sheet;
 
486
 
 
487
   procedure Set_Body
 
488
     (S : in String)
 
489
   is
 
490
   begin
 
491
      Body_Start := ASU.To_Unbounded_String (S);
 
492
   end Set_Body;
 
493
 
 
494
   procedure Set_Title
 
495
     (What : in HTML_Tag_Kind;
 
496
      S    : in String)
 
497
   is
 
498
   begin
 
499
      Title (What) := ASU.To_Unbounded_String (S);
 
500
   end Set_Title;
 
501
 
 
502
   procedure Set_Subtitle
 
503
     (What : in HTML_Tag_Kind;
 
504
      S    : in String)
 
505
   is
 
506
   begin
 
507
      Sub_Title (What) := ASU.To_Unbounded_String (S);
 
508
   end Set_Subtitle;
 
509
 
 
510
   procedure Set_Keyword
 
511
     (What : in HTML_Tag_Kind;
 
512
      S    : in String)
 
513
   is
 
514
   begin
 
515
      Keyword (What) := ASU.To_Unbounded_String (S);
 
516
   end Set_Keyword;
 
517
 
 
518
   procedure Set_Attribute
 
519
     (What : in HTML_Tag_Kind;
 
520
      S    : in String)
 
521
   is
 
522
   begin
 
523
      Attribute (What) := ASU.To_Unbounded_String (S);
 
524
   end Set_Attribute;
 
525
 
 
526
   procedure Set_Definition
 
527
     (What : in HTML_Tag_Kind;
 
528
      S    : in String)
 
529
   is
 
530
   begin
 
531
      Definition (What) := ASU.To_Unbounded_String (S);
 
532
   end Set_Definition;
 
533
 
 
534
   procedure Set_Comment
 
535
     (What : in HTML_Tag_Kind;
 
536
      S    : in String)
 
537
   is
 
538
   begin
 
539
      Comment (What) := ASU.To_Unbounded_String (S);
 
540
   end Set_Comment;
 
541
 
 
542
   procedure Set_Literal
 
543
     (What : in HTML_Tag_Kind;
 
544
      S    : in String)
 
545
   is
 
546
   begin
 
547
      Literal (What) := ASU.To_Unbounded_String (S);
 
548
   end Set_Literal;
 
549
 
 
550
begin
 
551
   Set_Char_Set    ("ISO-8859-1"); --  Latin 1
 
552
   Set_Style_Sheet ("adabrowse.css");
 
553
   Set_Body        ("<BODY BGCOLOR=""#FFFFF4"">");
 
554
 
 
555
   Set_Title (Before,
 
556
              "<TABLE WIDTH=""100%"" CLASS=""title"" " &
 
557
              "BORDER=0 CELLSPACING=0 CELLPADDING=5><TR><TD><H2>");
 
558
   Set_Title (After, "</H2></TD></TR></TABLE>");
 
559
 
 
560
   Set_Subtitle (Before, "<H3 CLASS=""subtitle"">");
 
561
   Set_Subtitle (After, "</H3>");
 
562
 
 
563
   Set_Keyword (Before, "<STRONG>");
 
564
   Set_Keyword (After, "</STRONG>");
 
565
 
 
566
   Set_Attribute (Before, "<STRONG>");
 
567
   Set_Attribute (After, "</STRONG>");
 
568
 
 
569
   Set_Definition (Before, "<SPAN CLASS=""definition"">");
 
570
   Set_Definition (After, "</SPAN>");
 
571
 
 
572
   Set_Comment (Before, "<EM><SPAN CLASS=""comment"">");
 
573
   Set_Comment (After, "</SPAN></EM>");
 
574
 
 
575
   Set_Literal (Before, "<SPAN CLASS=""literal"">");
 
576
   Set_Literal (After, "</SPAN>");
 
577
 
 
578
   Ending (Before) :=
 
579
     ASU.To_Unbounded_String
 
580
       ("<HR><TABLE WIDTH=""100%"" CLASS=""footer"" " &
 
581
        "BORDER=0 CELLSPACING=0 CELLPADDING=5><TR><TD><FONT SIZE=-1>");
 
582
 
 
583
   Ending (After) :=
 
584
     ASU.To_Unbounded_String ("</FONT></TD></TR></TABLE>");
 
585
end AD.HTML;
 
586
 
 
587