1. with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; 
  2. with Ada.Exceptions;         use Ada.Exceptions; 
  3. with Basic_Io;               use Basic_Io; 
  4. package body HTML is 
  5.  
  6. -------------------------------------------------------------------------------- 
  7.    function HTML_Document 
  8.      (Head_Contens : Unbounded_String := Null_Unbounded_String; 
  9.       Body_Contens : Unbounded_String := Null_Unbounded_String) return Unbounded_String is 
  10.       DocType : Unbounded_String := 
  11.         To_Unbounded_String 
  12.           ("<!DOCTYPE html PUBLIC " & 
  13.            Quotation & 
  14.            "-//W3C//DTD HTML 4.01//EN" & 
  15.            Quotation & 
  16.            ' ' & 
  17.            Quotation & 
  18.            "http://www.w3.org/TR/html4/strict.dtd" & 
  19.            Quotation & 
  20.            ">" & 
  21.            LF); 
  22.       HTML_Begin : Unbounded_String := To_Unbounded_String ("<html>" & LF & LF); 
  23.       HTML_End   : Unbounded_String := To_Unbounded_String ("</html>"); 
  24.       HTML_Head  : Unbounded_String := 
  25.         To_Unbounded_String ("<head>" & LF) & Head_Contens & To_Unbounded_String (LF & "</head>" & LF & LF); 
  26.       HTML_Body : Unbounded_String := 
  27.         To_Unbounded_String ("<body>" & LF & LF) & Body_Contens & LF & "</body>" & LF & LF; 
  28.    begin 
  29.       return DocType & HTML_Begin & HTML_Head & HTML_Body & HTML_End; 
  30.    end HTML_Document; 
  31. -------------------------------------------------------------------------------- 
  32.  
  33. -------------------------------------------------------------------------------- 
  34.    function Table (Lines : Unbounded_String := Null_Unbounded_String) return Unbounded_String is 
  35.       Table : Unbounded_String := Null_Unbounded_String; 
  36.    begin 
  37.       Table := 
  38.         "<table style=" & 
  39.         Quotation & 
  40.         "border-color:#000000; border:1px solid; padding:0px; border-collapse:collapse" & 
  41.         Quotation & 
  42.         ">" & 
  43.         LF & 
  44.         Lines & 
  45.         "</table>" & 
  46.         LF; 
  47.       return Table; 
  48.    exception 
  49.       when Error : others => 
  50.          Put_Line ("Error in function Table!"); 
  51.          Put_Line ("Exception_Information: " & Ada.Exceptions.Exception_Information (Error)); 
  52.          return Null_Unbounded_String; 
  53.    end Table; 
  54. -------------------------------------------------------------------------------- 
  55.  
  56. -------------------------------------------------------------------------------- 
  57.    Head_Line_Style : constant Unbounded_String := To_Unbounded_String ("background-color:#E0FFFF; font-weight:bold;"); 
  58. -------------------------------------------------------------------------------- 
  59.  
  60. -------------------------------------------------------------------------------- 
  61.    function Line 
  62.      (Item_List  : Unbounded_String; 
  63.       Head_Line  : Boolean         := False) return Unbounded_String is 
  64.       Line : Unbounded_String := Null_Unbounded_String; 
  65.    begin 
  66.       if Head_Line then 
  67.          Line := "   <tr style=" & Quotation & Head_Line_Style & Quotation & ">" & LF & Item_List & "   </tr>" & LF; 
  68.       else 
  69.          Line := 
  70.            "   <tr style=" & 
  71.            Quotation & 
  72.            "padding:0px; margin:0px;" & 
  73.            Quotation & 
  74.            ">" & 
  75.            LF & 
  76.            Item_List & 
  77.            "   </tr>" & 
  78.            LF; 
  79.       end if; 
  80.       return Line; 
  81.    exception 
  82.       when Error : others => 
  83.          Put_Line ("Error in function Line!"); 
  84.          Put_Line ("Exception_Information: " & Ada.Exceptions.Exception_Information (Error)); 
  85.          return Null_Unbounded_String; 
  86.    end Line; 
  87. -------------------------------------------------------------------------------- 
  88.  
  89. -------------------------------------------------------------------------------- 
  90.    function Item 
  91.      (Contens           : Unbounded_String; 
  92.       Mark_First_Column : Boolean         := False; 
  93.       Text_Align        : Text_Align_Type := Center) return Unbounded_String is 
  94.       Item : Unbounded_String := Null_Unbounded_String; 
  95.  
  96.       Text_Align_Center : String := "text-align:center; "; 
  97.       Text_Align_Left   : String := "text-align:left; "; 
  98.       Text_Align_Right  : String := "text-align:right; "; 
  99.  
  100.       Style        : Unbounded_String := Null_Unbounded_String; 
  101.       Default_Part : String           := "padding:3px; border-color:#ffffff; border:1px solid; margin:0px;"; 
  102.  
  103.    begin 
  104.  
  105.       case Text_Align is 
  106.          when Center => 
  107.             Style := To_Unbounded_String (Text_Align_Center & Default_Part); 
  108.          when Left => 
  109.             Style := To_Unbounded_String (Text_Align_Left & Default_Part); 
  110.          when Right => 
  111.             Style := To_Unbounded_String (Text_Align_Right & Default_Part); 
  112.       end case; 
  113.  
  114.       if Mark_First_Column then 
  115.          Item := "      <td style=" & Quotation & Style & Head_Line_Style & Quotation & ">" & Contens & "</td>" & LF; 
  116.       else 
  117.          Item := "      <td style=" & Quotation & Style & Quotation & ">" & Contens & "</td>" & LF; 
  118.       end if; 
  119.       return Item; 
  120.    exception 
  121.       when Error : others => 
  122.          Put_Line ("Error in function Item!"); 
  123.          Put_Line ("Exception_Information: " & Ada.Exceptions.Exception_Information (Error)); 
  124.          return Null_Unbounded_String; 
  125.    end Item; 
  126. -------------------------------------------------------------------------------- 
  127.  
  128. -------------------------------------------------------------------------------- 
  129.    function Item (Contens : String; Mark_First_Column : Boolean := False) return Unbounded_String is 
  130.       Item : Unbounded_String := Null_Unbounded_String; 
  131.    begin 
  132.       if Mark_First_Column then 
  133.          Item := 
  134.            "      <td style=" & 
  135.            Quotation & 
  136.            "text-align:center; padding:4px border-color:#ffffff; border:1px solid; margin:0px;" & 
  137.            Head_Line_Style & 
  138.            Quotation & 
  139.            ">" & 
  140.            To_Unbounded_String (Contens) & 
  141.            "</td>" & 
  142.            LF; 
  143.       else 
  144.          Item := 
  145.            "      <td style=" & 
  146.            Quotation & 
  147.            "text-align:center; padding:4px border-color:#ffffff; border:1px solid; margin:0px;" & 
  148.            Quotation & 
  149.            ">" & 
  150.            To_Unbounded_String (Contens) & 
  151.            "</td>" & 
  152.            LF; 
  153.       end if; 
  154.       return Item; 
  155.    exception 
  156.       when Error : others => 
  157.          Put_Line ("Error in function Item!"); 
  158.          Put_Line ("Exception_Information: " & Ada.Exceptions.Exception_Information (Error)); 
  159.          return Null_Unbounded_String; 
  160.    end Item; 
  161. -------------------------------------------------------------------------------- 
  162.  
  163. -------------------------------------------------------------------------------- 
  164.    function Table 
  165.      (Matrix            : String_Matrix_Type; 
  166.       Head_Line         : Boolean         := False; 
  167.       Mark_first_Column : Boolean         := False; 
  168.       Text_Align        : Text_Align_Type := Center; 
  169.       Display_Steps     : Boolean         := False) return Unbounded_String is 
  170.       Table : Unbounded_String := Null_Unbounded_String; 
  171.  
  172.       HTML_Contens : Unbounded_String := Null_Unbounded_String; 
  173.       Lines        : Unbounded_String := Null_Unbounded_String; 
  174.       Item_List    : Unbounded_String := Null_Unbounded_String; 
  175.  
  176.    begin 
  177.       for i in Matrix'range (1) loop 
  178.          for j in Matrix'range (2) loop 
  179.             if j = Matrix'first (2) then 
  180.                Item_List := Item_List & HTML.Item (Matrix (i, j), Mark_First_Column => Mark_first_Column,Text_Align => Text_Align); 
  181.             else 
  182.                Item_List := Item_List & HTML.Item (Matrix (i, j),Text_Align => Text_Align); 
  183.             end if; 
  184.             if Display_Steps then 
  185.                Put (Matrix (i, j) & " "); 
  186.             end if; 
  187.          end loop; 
  188.  
  189.          if Display_Steps then 
  190.             New_Line; 
  191.          end if; 
  192.  
  193.          if i = Matrix'first (1) then 
  194.             Lines := Lines & HTML.Line (Item_List, Head_Line => Head_Line); 
  195.          else 
  196.             Lines := Lines & HTML.Line (Item_List); 
  197.          end if; 
  198.          Item_List := Null_Unbounded_String; 
  199.       end loop; 
  200.       Table := HTML.Table (Lines); 
  201.       return Table; 
  202.    exception 
  203.       when Error : others => 
  204.          Put_Line ("Error in function Table!"); 
  205.          Put_Line ("Exception_Information: " & Ada.Exceptions.Exception_Information (Error)); 
  206.          return Null_Unbounded_String; 
  207.    end Table; 
  208. -------------------------------------------------------------------------------- 
  209.  
  210. -------------------------------------------------------------------------------- 
  211. end HTML; ---------------------------------------------------------------------- 
  212. --------------------------------------------------------------------------------