-----------------------------------------------------------------------
--  wiki-filters-html -- Wiki HTML filters
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Wide_Wide_Characters.Handling;
package body Wiki.Filters.Html is

   function Tag (Name   : in Wide_Wide_String;
                 Expect : in Wide_Wide_String;
                 Tag    : in Html_Tag_Type) return Html_Tag_Type;

   function Need_Close (Tag         : in Html_Tag_Type;
                        Current_Tag : in Html_Tag_Type) return Boolean;

   type Tag_Name_Array is array (Html_Tag_Type) of Unbounded_Wide_Wide_String;

   No_End_Tag   : constant Tag_Boolean_Array :=
     (
      BASE_TAG   => True,
      LINK_TAG   => True,
      META_TAG   => True,
      IMG_TAG    => True,
      HR_TAG     => True,
      BR_TAG     => True,
      WBR_TAG    => True,
      INPUT_TAG  => True,
      KEYGEN_TAG => True,
      others     => False);

   Tag_Omission : constant Tag_Boolean_Array :=
     (
      --  Section 4.4 Grouping content
      LI_TAG    => True,
      DT_TAG    => True,
      DD_TAG    => True,

      --  Section 4.5 Text-level semantics
      RB_TAG    => True,
      RT_TAG    => True,
      RTC_TAG   => True,
      RP_TAG    => True,

      --  Section 4.9 Tabular data
      TH_TAG    => True,
      TD_TAG    => True,
      TR_TAG    => True,
      TBODY_TAG => True,
      THEAD_TAG => True,
      TFOOT_TAG => True,

      OPTGROUP_TAG => True,
      OPTION_TAG   => True,

      others    => False);

   Tag_Names : constant Tag_Name_Array
     := (

         B_TAG     => To_Unbounded_Wide_Wide_String ("b"),
         I_TAG     => To_Unbounded_Wide_Wide_String ("i"),
         U_TAG     => To_Unbounded_Wide_Wide_String ("u"),
         IMG_TAG   => To_Unbounded_Wide_Wide_String ("img"),
         HR_TAG    => To_Unbounded_Wide_Wide_String ("hr"),
         BR_TAG    => To_Unbounded_Wide_Wide_String ("br"),
         SPAN_TAG  => To_Unbounded_Wide_Wide_String ("span"),
         DL_TAG    => To_Unbounded_Wide_Wide_String ("dl"),
         DT_TAG    => To_Unbounded_Wide_Wide_String ("dt"),
         DD_TAG    => To_Unbounded_Wide_Wide_String ("dd"),
         TABLE_TAG => To_Unbounded_Wide_Wide_String ("table"),
         TBODY_TAG => To_Unbounded_Wide_Wide_String ("tbody"),
         THEAD_TAG => To_Unbounded_Wide_Wide_String ("thead"),
         TFOOT_TAG => To_Unbounded_Wide_Wide_String ("tfoot"),
         TH_TAG    => To_Unbounded_Wide_Wide_String ("th"),
         TR_TAG    => To_Unbounded_Wide_Wide_String ("tr"),
         TD_TAG    => To_Unbounded_Wide_Wide_String ("td"),
         others    => Null_Unbounded_Wide_Wide_String);

   function Tag (Name   : in Wide_Wide_String;
                 Expect : in Wide_Wide_String;
                 Tag    : in Html_Tag_Type) return Html_Tag_Type is
   begin
      if Ada.Wide_Wide_Characters.Handling.To_Lower (Name) = Expect then
         return Tag;
      else
         return UNKNOWN_TAG;
      end if;
   end Tag;

   --  ------------------------------
   --  Find the tag from the tag name.
   --  ------------------------------
   function Find_Tag (Name : in Wide_Wide_String) return Html_Tag_Type is
   begin
      --  The list of possible tags is well known and will not change very often.
      --  The tag lookup is implemented to be efficient with 2 or 3 embedded cases that
      --  reduce the comparison to the minimum.  The result is a large case statement that
      --  becomes unreadable.
      case Name'Length is
         when 0 =>
            return UNKNOWN_TAG;

         when 1 =>
            case Name (Name'First) is
            when 'a' | 'A' =>
               return A_TAG;
            when 'b' | 'B' =>
               return B_TAG;
            when 'i' | 'I' =>
               return I_TAG;
            when 'p' | 'P' =>
               return P_TAG;
            when 'q' | 'Q' =>
               return Q_TAG;
            when 's' | 'S' =>
               return S_TAG;
            when 'u' | 'U' =>
               return U_TAG;
            when others =>
               return UNKNOWN_TAG;
            end case;

         when 2 =>
            case Name (Name'First) is
            when 'b' | 'B' =>
               case Name (Name'Last) is
                  when 'r' | 'R' =>
                     return BR_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'd' | 'D' =>
               case Name (Name'Last) is
                  when 'l' | 'L' =>
                     return DL_TAG;
                  when 't' | 'T' =>
                     return DT_TAG;
                  when 'd' | 'D' =>
                     return DD_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'e' | 'E' =>
               case Name (Name'Last) is
                  when 'm' | 'M' =>
                     return EM_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'h' | 'H' =>
               case Name (Name'Last) is
                  when '1' =>
                     return H1_TAG;
                  when '2' =>
                     return H2_TAG;
                  when '3' =>
                     return H3_TAG;
                  when '4' =>
                     return H4_TAG;
                  when '5' =>
                     return H5_TAG;
                  when '6' =>
                     return H6_TAG;
                  when 'r' | 'R' =>
                     return HR_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'l' | 'L' =>
               case Name (Name'Last) is
                  when 'i' | 'I' =>
                     return LI_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'o' | 'O' =>
               case Name (Name'Last) is
                  when 'l' | 'L' =>
                     return OL_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'r' | 'R' =>
               case Name (Name'Last) is
                  when 'b' | 'B' =>
                     return RB_TAG;
                  when 'p' | 'P' =>
                     return RP_TAG;
                  when 't' | 'T' =>
                     return RT_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 't' | 'T' =>
               case Name (Name'Last) is
                  when 'r' | 'R' =>
                     return TR_TAG;
                  when 'd' | 'D' =>
                     return TD_TAG;
                  when 'h' | 'H' =>
                     return TH_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'u' | 'U' =>
               case Name (Name'Last) is
                  when 'l' | 'L' =>
                     return UL_TAG;
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when others =>
               return UNKNOWN_TAG;

            end case;

         when 3 =>
            case Name (Name'First) is
            when 'b' | 'B' =>
               case Name (Name'Last) is
                  when 'i' | 'I' =>
                     return Tag (Name, "bdi", BDI_TAG);
                  when 'o' | 'O' =>
                     return Tag (Name, "bdo", BDO_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'c' | 'C' =>
               return Tag (Name, "col", COL_TAG);

            when 'd' | 'D' =>
               case Name (Name'First + 1) is
                  when 'i' | 'I' =>
                     return Tag (Name, "div", DIV_TAG);
                  when 'f' | 'F' =>
                     return Tag (Name, "dfn", DFN_TAG);
                  when 'e' | 'E' =>
                     return Tag (Name, "del", DEL_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'i' | 'I' =>
               case Name (Name'Last) is
                  when 'g' | 'G' =>
                     return Tag (Name, "img", IMG_TAG);
                  when 's' | 'S' =>
                     return Tag (Name, "ins", INS_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'k' | 'K' =>
               return Tag (Name, "kbd", KBD_TAG);

            when 'm' | 'M' =>
               return Tag (Name, "map", MAP_TAG);

            when 'n' | 'N' =>
               return Tag (Name, "nav", NAV_TAG);

            when 'p' | 'P' =>
               return Tag (Name, "pre", PRE_TAG);

            when 'r' | 'R' =>
               return Tag (Name, "rtc", RTC_TAG);

            when 's' | 'S' =>
               case Name (Name'Last) is
                  when 'b' | 'B' =>
                     return Tag (Name, "sub", SUB_TAG);
                  when 'n' | 'N' =>
                     return SPAN_TAG;
                  when 'p' | 'P' =>
                     return Tag (Name, "sup", SUP_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'v' | 'V' =>
               return Tag (Name, "var", VAR_TAG);

            when 'w' | 'W' =>
               return Tag (Name, "wbr", WBR_TAG);

            when others =>
               return UNKNOWN_TAG;
            end case;

         when 4 =>
            case Name (Name'First) is
            when 'a' | 'A' =>
               case Name (Name'First + 1) is
                  when 'b' | 'B' =>
                     return Tag (Name, "abbr", ABBR_TAG);
                  when 'r' | 'R' =>
                     return Tag (Name, "area", AREA_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'b' | 'B' =>
               case Name (Name'First + 1) is
                  when 'a' | 'A' =>
                     return Tag (Name, "base", BASE_TAG);
                  when 'o' | 'O' =>
                     return Tag (Name, "body", BODY_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'c' | 'C' =>
               case Name (Name'First + 1) is
                  when 'i' | 'I' =>
                     return Tag (Name, "cite", CITE_TAG);
                  when 'o' | 'O' =>
                     return Tag (Name, "code", CODE_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'd' | 'D' =>
               return Tag (Name, "data", DATA_TAG);

            when 'f' | 'F' =>
               return Tag (Name, "form", FORM_TAG);

            when 'h' | 'H' =>
               case Name (Name'First + 1) is
                  when 't' | 'T' =>
                     return Tag (Name, "html", HTML_TAG);
                  when 'e' | 'E' =>
                     return Tag (Name, "head", HEAD_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'l' | 'L' =>
               return Tag (Name, "link", LINK_TAG);

            when 'm' | 'M' =>
               case Name (Name'Last) is
                  when 'a' | 'A' =>
                     return Tag (Name, "meta", META_TAG);
                  when 'n' | 'N' =>
                     return Tag (Name, "main", MAIN_TAG);
                  when 'k' | 'K' =>
                     return Tag (Name, "mark", MARK_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'r' | 'R' =>
               return Tag (Name, "ruby", RUBY_TAG);

            when 's' | 'S' =>
               case Name (Name'First + 1) is
                  when 'p' | 'P' =>
                     return Tag (Name, "span", SPAN_TAG);
                  when 'a' | 'A' =>
                     return Tag (Name, "samp", SAMP_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 't' | 'T' =>
               return Tag (Name, "time", TIME_TAG);

            when others =>
               return UNKNOWN_TAG;
            end case;

         when 5 =>
            case Name (Name'First) is
            when 'a' | 'A' =>
               case Name (Name'First + 1) is
                  when 's' | 'S' =>
                     return Tag (Name, "aside", ASIDE_TAG);
                  when 'u' | 'U' =>
                     return Tag (Name, "audio", AUDIO_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'e' | 'E' =>
               return Tag (Name, "embed", EMBED_TAG);

            when 'i' | 'I' =>
               return Tag (Name, "input", INPUT_TAG);

            when 'l' | 'L' =>
               return Tag (Name, "label", LABEL_TAG);

            when 'm' | 'M' =>
               return Tag (Name, "meter", METER_TAG);

            when 'p' | 'P' =>
               return Tag (Name, "param", PARAM_TAG);

            when 's' | 'S' =>
               case Name (Name'First + 1) is
                  when 't' | 'T' =>
                     return Tag (Name, "style", STYLE_TAG);
                  when 'm' | 'M' =>
                     return Tag (Name, "small", SMALL_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 't' | 'T' =>
               case Name (Name'First + 1) is
                  when 'i' | 'I' =>
                     return Tag (Name, "title", TITLE_TAG);
                  when 'r' | 'R' =>
                     return Tag (Name, "track", TRACK_TAG);
                  when 'a' | 'A' =>
                     return Tag (Name, "table", TABLE_TAG);
                  when 'b' | 'B' =>
                     return Tag (Name, "tbody", TBODY_TAG);
                  when 'h' | 'H' =>
                     return Tag (Name, "thead", THEAD_TAG);
                  when 'f' | 'F' =>
                     return Tag (Name, "tfoot", TFOOT_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'v' | 'V' =>
               return Tag (Name, "video", VIDEO_TAG);

            when others =>
               return UNKNOWN_TAG;
            end case;

         when others =>
            case Name (Name'First) is
            when 'a' | 'A' =>
               case Name (Name'First + 1) is
                  when 'r' | 'R' =>
                     return Tag (Name, "article", ARTICLE_TAG);
                  when 'd' | 'D' =>
                     return Tag (Name, "address", ADDRESS_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'b' | 'B' =>
               case Name (Name'First + 1) is
                  when 'l' | 'L' =>
                     return Tag (Name, "blockquote", BLOCKQUOTE_TAG);
                  when 'u' | 'U' =>
                     return Tag (Name, "button", BUTTON_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'c' | 'C' =>
               case Name (Name'First + 2) is
                  when 'p' | 'P' =>
                     return Tag (Name, "caption", CAPTION_TAG);
                  when 'l' | 'L' =>
                     return Tag (Name, "colgroup", COLGROUP_TAG);
                  when 'n' | 'N' =>
                     return Tag (Name, "canvas", CANVAS_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'd' | 'D' =>
               return Tag (Name, "datalist", DATALIST_TAG);

            when 'f' | 'F' =>
               case Name (Name'Last) is
                  when 'r' | 'R' =>
                     return Tag (Name, "footer", FOOTER_TAG);
                  when 'e' | 'E' =>
                     return Tag (Name, "figure", FIGURE_TAG);
                  when 'n' | 'N' =>
                     return Tag (Name, "figcaption", FIGCAPTION_TAG);
                  when 't' | 'T' =>
                     return Tag (Name, "fieldset", FIELDSET_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'h' | 'H' =>
               return Tag (Name, "header", HEADER_TAG);

            when 'i' | 'I' =>
               return Tag (Name, "iframe", IFRAME_TAG);

            when 'k' | 'K' =>
               return Tag (Name, "keygen", KEYGEN_TAG);

            when 'l' | 'L' =>
               return Tag (Name, "legend", LEGEND_TAG);

            when 'n' | 'N' =>
               return Tag (Name, "noscript", NOSCRIPT_TAG);

            when 'o' | 'O' =>
               case Name (Name'First + 3) is
                  when 'e' | 'E' =>
                     return Tag (Name, "object", OBJECT_TAG);
                  when 'g' | 'G' =>
                     return Tag (Name, "optgroup", OPTGROUP_TAG);
                  when 'i' | 'I' =>
                     return Tag (Name, "option", OPTION_TAG);
                  when 'p' | 'P' =>
                     return Tag (Name, "output", OUTPUT_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 'p' | 'P' =>
               return Tag (Name, "progress", PROGRESS_TAG);

            when 's' | 'S' =>
               case Name (Name'First + 3) is
                  when 't' | 'T' =>
                     return Tag (Name, "section", SECTION_TAG);
                  when 'o' | 'O' =>
                     return Tag (Name, "strong", STRONG_TAG);
                  when 'r' | 'R' =>
                     return Tag (Name, "source", SOURCE_TAG);
                  when 'e' | 'E' =>
                     return Tag (Name, "select", SELECT_TAG);
                  when 'i' | 'I' =>
                     return Tag (Name, "script", SCRIPT_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when 't' | 'T' =>
               case Name (Name'Last) is
                  when 'a' | 'A' =>
                     return Tag (Name, "textarea", TEXTAREA_TAG);
                  when 'e' | 'E' =>
                     return Tag (Name, "template", TEMPLATE_TAG);
                  when others =>
                     return UNKNOWN_TAG;
               end case;

            when others =>
               return UNKNOWN_TAG;
            end case;
      end case;
   end Find_Tag;

   --  Add a text block with the given format.
   overriding
   procedure Add_Text (Document : in out Html_Filter_Type;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Wiki.Documents.Format_Map) is
   begin
      if not Document.Stack.Is_Empty then
         declare
            Current_Tag : constant Html_Tag_Type := Document.Stack.Last_Element;
         begin
            if No_End_Tag (Current_Tag) then
               Filter_Type (Document).End_Element (Tag_Names (Current_Tag));
               Document.Stack.Delete_Last;
            end if;
         end;
      end if;
      Filter_Type (Document).Add_Text (Text, Format);
   end Add_Text;

   --  Add a link.
   overriding
   procedure Add_Link (Document : in out Html_Filter_Type;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is
   begin
      if Document.Allowed (A_TAG) then
         Filter_Type (Document).Add_Link (Name, Link, Language, Title);
      end if;
   end Add_Link;

   --  Add an image.
   overriding
   procedure Add_Image (Document    : in out Html_Filter_Type;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is
   begin
      if Document.Allowed (IMG_TAG) then
         Filter_Type (Document).Add_Image (Link, Alt, Position, Description);
      end if;
   end Add_Image;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag_Type;
                        Current_Tag : in Html_Tag_Type) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   overriding
   procedure Start_Element (Document   : in out Html_Filter_Type;
                            Name       : in Unbounded_Wide_Wide_String;
                            Attributes : in Wiki.Attributes.Attribute_List_Type) is
      Tag         : constant Html_Tag_Type := Find_Tag (To_Wide_Wide_String (Name));
      Current_Tag : Html_Tag_Type;
   begin
      if not Document.Allowed (Tag) then
         return;
      end if;
      while not Document.Stack.Is_Empty loop
         Current_Tag := Document.Stack.Last_Element;
         if Need_Close (Tag, Current_Tag) then
            Filter_Type (Document).End_Element (Tag_Names (Current_Tag));
            Document.Stack.Delete_Last;
         end if;
         exit when not No_End_Tag (Current_Tag);
      end loop;
      Document.Stack.Append (Tag);
      Filter_Type (Document).Start_Element (Name, Attributes);
   end Start_Element;

   overriding
   procedure End_Element (Document : in out Html_Filter_Type;
                          Name     : in Unbounded_Wide_Wide_String) is
      Tag : constant Html_Tag_Type := Find_Tag (To_Wide_Wide_String (Name));
   begin
      if not Document.Allowed (Tag) or else Document.Stack.Is_Empty then
         return;
      end if;
      Document.Stack.Delete_Last;
      Filter_Type (Document).End_Element (Name);
   end End_Element;

   --  ------------------------------
   --  Flush the HTML element that have not yet been closed.
   --  ------------------------------
   procedure Flush_Stack (Document : in out Html_Filter_Type) is
   begin
      while not Document.Stack.Is_Empty loop
         declare
            Tag : constant Html_Tag_Type := Document.Stack.Last_Element;
         begin
            Filter_Type (Document).End_Element (Tag_Names (Tag));
         end;
         Document.Stack.Delete_Last;
      end loop;
   end Flush_Stack;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Document : in out Html_Filter_Type) is
   begin
      Document.Flush_Stack;
      Filter_Type (Document).Finish;
   end Finish;

   --  ------------------------------
   --  Mark the HTML tag as being forbidden.
   --  ------------------------------
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag_Type) is
   begin
      Filter.Allowed (Tag) := False;
   end Forbidden;

   --  ------------------------------
   --  Mark the HTML tag as being allowed.
   --  ------------------------------
   procedure Allowed (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type) is
   begin
      Filter.Allowed (Tag) := True;
   end Allowed;

end Wiki.Filters.Html;

Implement the HTML filter to block some HTML, do some corrections on HTML


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . C O N T T . D P                         --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2006, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with  ASIS-for-GNAT; see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines routines for computing and setting semantic
--  dependencies between ASIS Compilation Units

with Asis;            use Asis;
with Asis.Extensions; use Asis.Extensions;

package A4G.Contt.Dp is              --  Context_Table.DePendencies

   --  All the subprograms defined in this package are supposed, that
   --  (1) they are called at most once (depending on the unit kind) for any
   --      unit stored in the Context Unit table
   --  (2) the caller is responsible, that these subprograms are called for
   --      the actuals of appropriate kinds

   --  OPEN PROBLEMS:
   --
   --  1. DOCUMENTATION!!!
   --
   --  2. The idea is to *compute from the tree* only direct dependencies,
   --     and for all the indirect dependencies, to compute them from
   --     the direct dependencies using their transitive nature.

   procedure Set_Supporters (C : Context_Id; U : Unit_Id; Top : Node_Id);
   --  This procedure sets the **direct** supporters for U. For now,
   --  the idea is to set *from the tree* only the direct dependencies,
   --  as being the function of the source text of a Unit (???). All
   --  the indirect dependencies should be set from direct ones using
   --  the transitive nature of the dependencies.
   --
   --  So, for now, only Direct_Supporters, Direct_Dependants and
   --  Implicit_Supporters (representing only direct implicit dependencies
   --  imposed by implicit with clauses) are set by this procedure.
   --
   --  OPEN PROBLEM: If we set only **direct* dependencies, may be,
   --  we need only ONE function to do this? do we really need
   --  Set_Ancestors, Set_Childs, ????   ?

   procedure Set_Subunits (C : Context_Id; U : Unit_Id; Top : Node_Id);
   --  Sets the full list of the subunit for a given body (that is, adds
   --  nonexistent units for missed subunits)

   procedure Process_Stub (C : Context_Id; U : Unit_Id; Stub : Node_Id);
   --  Taking the node for a body stub, this function checks if the
   --  corresponding subunit exists in the Context C. If it does not exist,
   --  a unit of A_Nonexistent_Body kind is allocated in the Context Unit
   --  table and appended to the list of subunits of U.
   --
   --  This procedure supposes, that before it is called, the normalized
   --  name of U has been already set in A_Name_Buffer. When returning from
   --  this procedure, A_Name_Buffer and A_Name_Len are remained in the
   --  same state as before the call.

   procedure Append_Subunit_Name (Def_S_Name : Node_Id);
   --  Supposing that A_Name_Buf contains the name of the parent body, and
   --  Def_S_Name points to the defining identifier obtained from the body
   --  stub, this procedure forms in A_Name_Buffer the name of the subunit

   procedure Set_Withed_Units (C : Context_Id; U : Unit_Id; Top : Node_Id);
   --  This procedure sets the Direct_Supporters and Implicit_Supporters
   --  dependency lists on the base of with clauses explicicitly presented
   --  in unit's source and generated by the compiler respectively.

   procedure Set_Direct_Dependents (U : Unit_Id);
   --  This procedure is supposed to be called for U just after
   --  Set_Withed_Units has done its work. For any unit U1 included
   --  in the list of direct supporters for U, U is included in the list
   --  of direct dependers of U1.

   procedure Add_To_Parent (C : Context_Id; U : Unit_Id);
   --  Adds U to the list of children for its parent unit declaration.
   --  U is added to the list only it is consistent with the parent

   procedure Set_All_Dependencies (Use_First_New_Unit : Boolean := False);
   --  Sets all supportiers and all dependants for units contained in the
   --  argument Context. Should be called when all the units are already set.
   --  If Use_First_New_Unit is set ON (this may happen for Incremental
   --  Context only), completes the dependencies only for new units from the
   --  new tree (see the body of A4G.Get_Unit.Fetch_Unit_By_Ada_Name)

   procedure Set_All_Ancestors
     (Compilation_Units :         Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access);
   --  This procedure takes the arguments of
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in
   --  case when Relation parameter is set to Ancestors and computes the
   --  consistent part of the result.(???)

   procedure Set_All_Descendants
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access);
   --  This procedure takes the arguments of
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in
   --  case when Relation parameter is set to Descendants and computes the
   --  consistent part of the result.(???)

   procedure Set_All_Supporters
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access);
   --  This procedure takes the arguments of
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in
   --  case when Relation parameter is set to Supporters and
   --  computes the consistent part of the result.(???)

   procedure Set_All_Dependents
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Dependent_Units   :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access);
   --  This procedure takes the arguments of
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in
   --  case when Relation parameter is set to Dependents and computes the
   --  consistent part of the result.(???)

   procedure Set_All_Families
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access);
   --  This procedure takes the arguments of
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in
   --  case when Relation parameter is set to Family and
   --  computes the consistent part of the result.(???)

   procedure Set_All_Needed_Units
     (Compilation_Units :        Asis.Compilation_Unit_List;
      Result            : in out Compilation_Unit_List_Access;
      Missed            : in out Compilation_Unit_List_Access);
   --  This procedure takes the arguments of
   --  Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in
   --  case when Relation parameter is set to Needed_Units and
   --  computes the consistent part of the result and missed units.(???)

end A4G.Contt.Dp;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  ado-datasets-tests -- Test executing queries and using datasets
--  Copyright (C) 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Test_Caller;
with Util.Properties;

with Regtests.Simple.Model;
with ADO.Queries.Loaders;
package body ADO.Datasets.Tests is

   package Caller is new Util.Test_Caller (Test, "ADO.Datasets");

   package User_List_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/user-list.xml",
                                   Sha1 => "");

   package User_List_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list",
                                    File => User_List_Query_File.File'Access);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Datasets.List",
                       Test_List'Access);
   end Add_Tests;

   procedure Test_List (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Data   : ADO.Datasets.Dataset;
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"),
                                      Props.Get ("ado.queries.load", "false") = "true");
      for I in 1 .. 100 loop
         declare
            User : Regtests.Simple.Model.User_Ref;
         begin
            User.Set_Name ("John " & Integer'Image (I));
            User.Set_Select_Name ("test-list");
            User.Set_Value (ADO.Identifier (I));
            User.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100, Data.Get_Count, "Invalid dataset size");
   end Test_List;

end ADO.Datasets.Tests;

Implement the unit test on datasets

Implement the unit test on datasets


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . G E T _ U N I T                         --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2005, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with A4G.A_Types; use A4G.A_Types;

package A4G.Get_Unit is

--  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--  !!                                                                 !!
--  !!  This package should be completely revised (and very likely -   !!
--  !!  removed), when migration to using pre-created trees as to the  !!
--  !!  *ONLY* ASIS operation mode is completed                        !!
--  !!                                                                 !!
--  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--  This paskage contains routines for obtaining ASIS Compilation Units
--  according to the requests arosen during processing the queries from
--  Asis.Compilation_Units package which get Units and Unit Lists from an
--  ASIS Context. As the first step, these routines try to find the
--  reqiested unit(s) by making the corresponding search among Units
--  which are already known to ASIS by looking for the Units in the internal
--  tables implementing the ASIS Context Model. If this first step does not
--  give the required resuil, the attempt to fing the Unit(s) by processing
--  the Ada sources or pre-created tree output files is undertaken. To obtain
--  information about the Unit which has never been known to ASIS, ASIS has,
--  depending on the options set for a context, either to compile it "on the
--  fly" in order to check its correctness and to produce the tree output
--  file, if the Unit is correct, or to try to locate the pre-created tree
--  output file; then the tree output file has to be read in and analysed.
--  If the tree contains the subtrees for other Ada units which have not
--  been known to ASIS so far, ASIS stores the information about these units
--  in its internal tables (even the ASIS query being processed has no
--  relation to these units).

   -----------------
   -- Subprograms --
   -----------------

   function Get_One_Unit
     (Name    : Wide_String;
      Context : Context_Id;
      Spec    : Boolean)
      return    Unit_Id;
   --  This function defines the top-level control flow for the two
   --  functions from the Asis_Compilation_Unit package which yields
   --  one ASIS Compilation Unit: Library_Unit_Declaration and
   --  Compilation_Unit_Body. Spec is used to make the diffference
   --  between these two functions: it is set True for
   --  Library_Unit_Declaration and False for Compilation_Unit_Body.

   function Fetch_Unit_By_Ada_Name
     (Name      : String;
      Norm_Name : String;
      Context   : Context_Id;
      Spec      : Boolean)
      return      Unit_Id;
   --  This function is supposed to be called in the following situation:
   --
   --  -  Name is non-empty string which can be interpreted as an Ada unit
   --     name;
   --
   --  -  Norm_Name is non-empty string representing the normalised version
   --     of the Ada unit name passed as the actual for Name. This means
   --     that Norm_Name'Legth = Name'Length + 2, and Norm_name ends with
   --     "%s" or "%b" DEPENDING ON THE VALUE OF SPEC;
   --
   --  The Context parameter indicates the ASIS Context to look for a Unit
   --  indicated by Name and Norm_Name. Spec indicates whether the library
   --  unit declaration or the compilation unit body should be fetched
   --  (See the documentation for the functions Library_Unit_Declaration
   --  and Compilation_Unit_Body from the Asis_Compilation_Units package
   --  for the definition of the ASIS meaning of "library unit declaration"
   --  and "compilation unit body").
   --
   --  This function returns the Unit_Id value indicating the desired
   --  Unit. Nil_Unit is returned if Context does not contain the   -- ##
   --  Unit having Name as its unit name.
   --
   --  If ASIS already knows this Unit, the returned Unit_Id value
   --  points to some pre-existing entry in the Unit Table for the given
   --  Context. Otherwise ASIS tries to compile Unit from its cource.
   --  If the compilation is successful, ASIS retrieves the newly
   --  created tree and it obtains and stores in the Unit Table
   --  information about the Unit AND ABOUT ALL IS SUPPORTERS, WHICH
   --  ARE NOT KNOWN TO ASIS!
   --
   --  !!! THIS FUNCTION SHOULD ANALYZE EXISTING TREES BEFORE TRYING
   --  !!! TO CREATE THE NEW TREE, THIS IS NOT IMPLEMENTED YET
   --
   --  IMPLEMENTATION LIMITATION : if the file name of an Ada unit is
   --  defined by the Source_File_Name pragma, ASIS cannot call GNAT
   --  to compile this unit!

   function Get_Main_Unit_Tree_On_The_Fly
     (Start_Unit : Unit_Id;
      Cont       : Context_Id;
      Spec       : Boolean)
      return       Unit_Id;
   --  This function is supposed to be used for the Incremental Context mode
   --  only. It purpose is to try to create the main tree for Start_Unit
   --  (if Spec is set ON) or for the body of Start_Unit (if Spec is set OFF).
   --  If the tree is successfully created, this function returns either
   --  Start_From or the Id of the body of Start_From respectively, otherwise
   --  Nil_Unit is returned.
   --
   --  If this function creates the new tree, this tree is added to the set
   --  of trees making up the current incremental context, and this tree
   --  becomes the tree currently accessed by ASIS.
   --
   --  This function is supposed to be called with Start_Unit representing
   --  some spec unit in the Cont. It is also supposed that the tree which
   --  should be created by the call does not exist in Cont. The caller is
   --  responsible to insure these conditions.
   --  condition

end A4G.Get_Unit;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  awa-questions-tests -- Unit tests for questions module
--  Copyright (C) 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Strings;

with Servlet.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Questions.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Questions");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Load_List (Anonymous)",
                       Test_Anonymous_Access'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Save",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Load (missing)",
                       Test_Missing_Page'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the wiki as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String) is
      function Get_Link (Title : in String) return String;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;

      function Get_Link (Title : in String) return String is
         Stream  : Servlet.Streams.Print_Stream := Reply.Get_Output_Stream;
         Content : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Reply.Read_Content (Content);
         Stream.Write (Content);
         return AWA.Tests.Helpers.Extract_Link (To_String (Content), Title);
      end Get_Link;

   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/list.html",
                        "question-list.html");
      ASF.Tests.Assert_Contains (T, "<title>Questions</title>", Reply,
                                 "Questions list page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/questions/tags/tag",
                        "question-list-tagged.html");
      ASF.Tests.Assert_Contains (T, "<title>Questions</title>", Reply,
                                 "Questions tag page is invalid");

      if Page'Length > 0 then
         ASF.Tests.Do_Get (Request, Reply, "/questions/view/" & Page,
                           "question-page-" & Page & ".html");
         ASF.Tests.Assert_Contains (T, Title, Reply,
                                    "Question page " & Page & " is invalid");
         ASF.Tests.Assert_Contains (T, "<h2>" & Title & "</h2>", Reply,
                                    "Question page " & Page & " is invalid");
         ASF.Tests.Assert_Matches (T, ".input type=.hidden. name=.question-id. "
                                   & "value=.[0-9]+. id=.question-id.../input", Reply,
                                    "Question page " & Page & " is invalid");
      end if;
   end Verify_Anonymous;

   --  ------------------------------
   --  Verify that the question list contains the given question.
   --  ------------------------------
   procedure Verify_List_Contains (T     : in out Test;
                                   Id    : in String;
                                   Title : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/list.html",
                        "question-list-recent.html");
      ASF.Tests.Assert_Contains (T, "Questions", Reply,
                                 "List of questions page is invalid");
      ASF.Tests.Assert_Contains (T, "/questions/view/" & Id, Reply,
                                 "List of questions page does not reference the page");
      ASF.Tests.Assert_Contains (T, Title, Reply,
                                 "List of questions page does not contain the question");

   end Verify_List_Contains;

   --  ------------------------------
   --  Test access to the question as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("", "");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of question by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      procedure Create_Question (Title : in String);

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Uuid      : constant String := Util.Tests.Get_Uuid;

      procedure Create_Question (Title : in String) is
      begin
         Request.Set_Parameter ("post", "1");
         Request.Set_Parameter ("title", Title);
         Request.Set_Parameter ("text", "# Main title" & ASCII.LF
                                & "* The question content." & ASCII.LF
                                & "* Second item." & ASCII.LF);
         Request.Set_Parameter ("save", "1");
         ASF.Tests.Do_Post (Request, Reply, "/questions/ask.html", "questions-ask.html");

         T.Question_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/questions/view/");

         Util.Tests.Assert_Matches (T, "[0-9]+$", To_String (T.Question_Ident),
                                   "Invalid redirect after question creation");

         --  Remove the 'question' bean from the request so that we get a new instance
         --  for the next call.
         Request.Remove_Attribute ("question");
      end Create_Question;

   begin
      AWA.Tests.Helpers.Users.Login ("test-question@test.com", Request);

      Create_Question ("Question 1 page title1");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 1 page title1");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 1 page title1");

      Create_Question ("Question 2 page title2");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 2 page title2");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 2 page title2");

      Create_Question ("Question 3 page title3");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 3 page title3");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 3 page title3");

   end Test_Create_Question;

   --  ------------------------------
   --  Test getting a wiki page which does not exist.
   --  ------------------------------
   procedure Test_Missing_Page (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/view.html?id=12345678",
                        "question-page-missing.html");
      ASF.Tests.Assert_Matches (T, "<title>Question not found</title>", Reply,
                                "Question page title '12345678' is invalid",
                                ASF.Responses.SC_NOT_FOUND);
      ASF.Tests.Assert_Matches (T, "question.*removed", Reply,
                                "Question page content '12345678' is invalid",
                                ASF.Responses.SC_NOT_FOUND);
   end Test_Missing_Page;

end AWA.Questions.Tests;

Implement new tests for the questions module by simulating web requests


-----------------------------------------------------------------------
--  babel-files-queues -- File and directory queues
--  Copyright (C) 2014 Stephane.Carrez
--  Written by Stephane.Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Directories;
with Ada.Containers.Vectors;
with Util.Encoders.SHA1;
with Util.Concurrent.Fifos;
with Util.Strings.Vectors;
with ADO;
with Babel.Base.Models;
package body Babel.Files.Queues is

   --  ------------------------------
   --  Returns true if there is a directory in the queue.
   --  ------------------------------
   function Has_Directory (Queue : in Directory_Queue) return Boolean is
   begin
      return not Queue.Directories.Is_Empty;
   end Has_Directory;

   --  ------------------------------
   --  Get the next directory from the queue.
   --  ------------------------------
   procedure Peek_Directory (Queue     : in out Directory_Queue;
                             Directory : out Directory_Type) is
   begin
      Directory := Queue.Directories.Last_Element;
      Queue.Directories.Delete_Last;
   end Peek_Directory;

end Babel.Files.Queues;

Implement the Has_Directory and Peek_Directory operation for the Directory_Queue


--  Generated by utildgen.c from system includes
private package Util.Http.Clients.Curl.Constants is

   CURLOPT_URL            : constant Curl_Option := 10002;
   CURLOPT_HTTPGET        : constant Curl_Option := 80;
   CURLOPT_POST           : constant Curl_Option := 47;
   CURLOPT_CUSTOMREQUEST  : constant Curl_Option := 10036;
   CURLOPT_READFUNCTION   : constant Curl_Option := 20012;
   CURLOPT_WRITEUNCTION   : constant Curl_Option := 20011;
   CURLOPT_HTTPHEADER     : constant Curl_Option := 10023;
   CURLOPT_INTERFACE      : constant Curl_Option := 10062;
   CURLOPT_USERPWD        : constant Curl_Option := 10005;
   CURLOPT_HTTPAUTH       : constant Curl_Option := 107;
   CURLOPT_MAXFILESIZE    : constant Curl_Option := 114;
   CURLOPT_WRITEDATA      : constant Curl_Option := 10001;
   CURLOPT_HEADER         : constant Curl_Option := 42;
   CURLOPT_POSTFIELDS     : constant Curl_Option := 10015;
   CURLOPT_POSTFIELDSIZE  : constant Curl_Option := 60;
   CURLOPT_CONNECTTIMEOUT : constant Curl_Option := 78;
   CURLOPT_TIMEOUT        : constant Curl_Option := 13;

   CURLINFO_RESPONSE_CODE : constant CURL_Info := 2097154;

end Util.Http.Clients.Curl.Constants;

Add Curl.Constants package

Add Curl.Constants package


-----------------------------------------------------------------------
--  wiki-helpers-parser -- Generic procedure for the wiki parser
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Wiki.Helpers;
with Wiki.Streams;
procedure Wiki.Helpers.Parser (Engine  : in out Engine_Type;
                               Content : in Element_Type;
                               Doc     : in out Wiki.Documents.Document) is

   use type Wiki.Streams.Input_Stream_Access;

   type Wide_Input is new Wiki.Streams.Input_Stream with record
      Pos : Positive;
      Len : Natural;
   end record;

   overriding
   procedure Read (Buf    : in out Wide_Input;
                   Token  : out Wiki.Strings.WChar;
                   Is_Eof : out Boolean);

   procedure Read (Buf    : in out Wide_Input;
                   Token  : out Wiki.Strings.WChar;
                   Is_Eof : out Boolean) is
   begin
      if Buf.Pos > Buf.Len then
         Is_Eof := True;
         Token := Wiki.Helpers.CR;
      else
         Token := Element (Content, Buf.Pos);
         Buf.Pos := Buf.Pos + 1;
         Is_Eof := False;
      end if;
   end Read;

   Buffer : aliased Wide_Input;
begin
   Buffer.Pos   := 1;
   Buffer.Len   := Length (Content);
   Parse (Engine, Buffer'Unchecked_Access, Doc);
end Wiki.Helpers.Parser;

Implement the generic procedure Wiki.Helpers.Parser to allow easily provide a Parser with various content types


-----------------------------------------------------------------------
--  awa-counters-components -- Counter UI component
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ASF.Factory;
with ASF.Contexts.Faces;
with ASF.Components.Html;

--  == Counter Component ==
--
package AWA.Counters.Components is

   type UICounter is new ASF.Components.Html.UIHtmlComponent with private;

   --  Render the counter component.  Starts the DL/DD list and write the input
   --  component with the possible associated error message.
   overriding
   procedure Encode_Begin (UI      : in UICounter;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Get the AWA Counter component factory.
   function Definition return ASF.Factory.Factory_Bindings_Access;

private

   type UICounter is new ASF.Components.Html.UIHtmlComponent with null record;

end AWA.Counters.Components;

Change the UICounter to use the UIHtmlComponent base type


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . I T E S T S                            --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-1999, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines tests for defining if an Element based on the
--  given node should test Is_Implicit, Is_Inherited and Is_From_Instance

with Types; use Types;

package A4G.Itests is

   function Is_Inherited_Discriminant (N : Node_Id) return Boolean;
   --  Tests if N corresponds to the defining occurrence of an inherited
   --  discriminant. N should be of N_Defining_Identifier kind
   --
   --  INCOMPLETE and INRELIABLE for now!

   function Is_From_Instance (N : Node_Id) return Boolean;
   --  Tests if N corresponds to an implicit or explicit construction from
   --  the result of some generic instantiation (that is, from an expanded
   --  generic template)

end A4G.Itests;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  util-streams-buffered-lzma -- LZMA streams
--  Copyright (C) 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Encoders.Base64;
package body Util.Streams.Buffered.Lzma is

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   procedure Initialize (Stream  : in out Compress_Stream;
                         Output  : in Output_Stream_Access;
                         Size    : in Natural;
                         Format  : in String) is
   begin
      Stream.Initialize (Output, Size);
      Stream.Transform := new Util.Encoders.Lzma.Compress;
   end Initialize;

   --  -----------------------
   --  Close the sink.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Compress_Stream) is
   begin
      Stream.Flush;
      Stream.Output.Close;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Compress_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      First_Encoded : Ada.Streams.Stream_Element_Offset := Buffer'First;
      Last_Encoded  : Ada.Streams.Stream_Element_Offset;
      Last_Pos      : Ada.Streams.Stream_Element_Offset;
   begin
      while First_Encoded <= Buffer'Last loop
         Stream.Transform.Transform
           (Data    => Buffer (First_Encoded .. Buffer'Last),
            Into    => Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
            Last    => Last_Pos,
            Encoded => Last_Encoded);
         if Last_Encoded < Buffer'Last then
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Write_Pos := Stream.Buffer'First;
         else
            Stream.Write_Pos := Last_Pos + 1;
         end if;
         First_Encoded := Last_Encoded + 1;
      end loop;
   end Write;

   --  -----------------------
   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   --  -----------------------
   overriding
   procedure Flush (Stream : in out Compress_Stream) is
      Last_Pos : Ada.Streams.Stream_Element_Offset;
   begin
      loop
         Stream.Transform.Finish (Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
                                  Last_Pos);
         Stream.Write_Pos := Last_Pos + 1;
         Output_Buffer_Stream (Stream).Flush;
         exit when Stream.Write_Pos < Stream.Buffer'Last;
         Stream.Write_Pos := 1;
      end loop;
   end Flush;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Compress_Stream) is
   begin
      null;
   end Finalize;

end Util.Streams.Buffered.Lzma;

Implement the support for LZMA Compress_Stream


-----------------------------------------------------------------------
--  util-commands-tests - Test for commands
--  Copyright (C) 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;
with Util.Test_Caller;
with Util.Commands.Parsers.GNAT_Parser;
with Util.Commands.Drivers;
package body Util.Commands.Tests is

   package Caller is new Util.Test_Caller (Test, "Commands");

   type Test_Context_Type is record
      Number  : Integer;
      Success : Boolean := False;
   end record;

   package Test_Command is new
     Util.Commands.Drivers (Context_Type => Test_Context_Type,
                            Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                            Driver_Name  => "test");

   type Test_Command_Type is new Test_Command.Command_Type with record
      Opt_Count : aliased Integer := 0;
      Opt_V     : aliased Boolean := False;
      Opt_N     : aliased Boolean := False;
      Expect_V  : Boolean := False;
      Expect_N  : Boolean := False;
      Expect_C  : Integer := 0;
      Expect_A  : Integer := 0;
      Expect_Help : Boolean := False;
   end record;

   overriding
   procedure Execute (Command   : in Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type);

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration);

   --  Write the help associated with the command.
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Execute",
                       Test_Execute'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Help",
                       Test_Help'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Usage",
                       Test_Usage'Access);
   end Add_Tests;

   overriding
   procedure Execute (Command   : in Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type) is
   begin
      Context.Success := Command.Opt_Count = Command.Expect_C and
        Command.Opt_V = Command.Expect_V and
        Command.Opt_N = Command.Expect_N and
        Args.Get_Count = Command.Expect_A and
        not Command.Expect_Help;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration) is
   begin
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-c:",
                                       Long_Switch => "--count=",
                                       Help        => "Number option",
                                       Section     => "",
                                       Initial     => Integer (0),
                                       Default     => Integer (10),
                                       Output      => Command.Opt_Count'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-v",
                                       Long_Switch => "--verbose",
                                       Help        => "Verbose option",
                                       Section     => "",
                                       Output      => Command.Opt_V'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-n",
                                       Long_Switch => "--not",
                                       Help        => "Not option",
                                       Section     => "",
                                       Output      => Command.Opt_N'Access);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type) is

   begin
      Context.Success := Command.Expect_Help;
   end Help;

   --  ------------------------------
   --  Tests when the execution of commands.
   --  ------------------------------
   procedure Test_Execute (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := True;
         C1.Expect_N := True;
         C1.Expect_C := 4;
         C1.Expect_A := 2;
         Initialize (Args, "list --count=4 -v -n test titi");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := False;
         C1.Expect_N := True;
         C1.Expect_C := 8;
         C1.Expect_A := 3;
         Initialize (Args, "list -c 8 -n test titi last");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

   end Test_Execute;

   --  ------------------------------
   --  Test execution of help.
   --  ------------------------------
   procedure Test_Help (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C2.Expect_Help := True;
         Initialize (Args, "help print");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Help;

   --  ------------------------------
   --  Test usage operation.
   --  ------------------------------
   procedure Test_Usage (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      D.Usage (Args);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Usage;

end Util.Commands.Tests;

Implement unit tests for the Util.Commands and Util.Commands.Drivers package