-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 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 Util.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
  procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
   end record;

end Util.Serialize.IO.CSV;

-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 2016, 2017 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.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
   end record;

end Util.Serialize.IO.CSV;

Fix indentation

Fix indentation


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                             A 4 G . A _ S E M                            --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                                                                          --
--            Copyright (C) 1995-2012, 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 contains routines needed for semantic queries from
--  more than one Asis package

with Asis;         use Asis;

with A4G.Int_Knds; use A4G.Int_Knds;

with Einfo;        use Einfo;
with Types;        use Types;

package A4G.A_Sem is

   --  All the routines defined in this package do not check their
   --  arguments - a caller is responsible for the proper use of these
   --  routines

   ---------------------------------------
   -- Routines working on ASIS Elements --
   ---------------------------------------

   function Belongs_To_Limited_View (Decl : Asis.Element) return Boolean;
   --  Checks if the argument (declaration) Element may belong to a limited
   --  view of some package, see RM 05 10.1.1 (12.1/2 ..12.5/2))

   function Limited_View_Kind
     (Decl : Asis.Element)
      return Internal_Element_Kinds;
   --  Provided that Belongs_To_Limited_View (Decl), returns the rind that
   --  Decl should have in limited view (actually, the result is the kind of
   --  the argument except in case of type declarations, when the type is
   --  converted to An_Incomplete_Type_Declaration or
   --  A_Tagged_Incomplete_Type_Declaration

   function Get_Corr_Called_Entity
     (Call : Asis.Element)
      return Asis.Declaration;
   --  This function incapsulates the common code from
   --  Asis.Expressions.Corresponding_Called_Function and
   --  Asis.Statements.Corresponding_Called_Entity.
   --  It gets the Ada construction which is either a procedure (entry)
   --  or a function call and returns the declaration of the called
   --  entity. This function does not check this argument to be an
   --  appropriate Element for any of these ASIS queries.

   function Is_Range_Memberchip_Test (E : Asis.Element) return Boolean;
   function Is_Type_Memberchip_Test  (E : Asis.Element) return Boolean;
   --  These two functions are used as a check for appropriate Element in two
   --  obsolescent queries from Asis.Expressions - Membership_Test_Range and
   --  Membership_Test_Subtype_Mark respectively. They assume that an argument
   --  Element represents a membreship check Element. They check if the
   --  argument represents the membership test that in old ASIS was classified
   --  as An_In_Range_Membership_Test .. A_Not_In_Range_Membership_Test or
   --  An_In_Type_Membership_Test .. A_Not_In_Type_Membership_Test
   --  respectively.

   procedure Reset_For_Body
     (El        : in out Asis.Element;
      Body_Unit : Asis.Compilation_Unit);
   --  Provided that El is a declaration from the spec of a library package
   --  or a library generic package, this procedure resets El to Is_Identical
   --  Element, but obtained from the tree contained the body for this package.
   --  This body is represented by the Body_Unit parameter, we use it to avoid
   --  call to Asis.Compilation_Units.Corresponding_Body in the implementation
   --  of this function.

   ------------------------------------
   -- Routines working on tree nodes --
   ------------------------------------

   function Entity_Present (N : Node_Id) return Boolean;
   --  Differs from 'Present (Entity (N))' that in case if the check
   --  'Present (Entity (N))' does not point to an expression node as it
   --  happens for identifiers that identify aspects in aspect specifications.

   function Defined_In_Standard (N : Node_Id) return Boolean;
   --  checks if its argument is an identifier or an enumeration literal
   --  defined in the predefined Standard package

   function Char_Defined_In_Standard (N : Node_Id) return Boolean;
   --  Checks if its argument is a character literal defined in the
   --  predefined Standard package. Can be applied to reference nodes and
   --  entity nodes.

   function Unwind_Renaming (Def_Name : Node_Id) return Node_Id;
   --  Supposing that Def_Name is the node representing some defining
   --  occurrence of some name, this function unwinds all the renamings
   --  (if any) and returns the node representing the defining
   --  name of the entity referenced by this name. If there is no
   --  declaration for a given entity (this is the case, when a name
   --  renames a subprogram-attribute) an Empty node is returned.
   --
   --  Note, that the node for renaming declaration may be rewritten,
   --  in particular, renaming of a subprogram-attribute is rewritten
   --  into a subprogram body

   procedure Set_Stub_For_Subunit_If_Any (Def_Name : in out Node_Id);
   --  If Def_Name is N_Defining_Identifier node which represents the
   --  subprogram defining identifier from the proper body of a subunit,
   --  it is reset to point to the corresponding N_Defining_Identifier
   --  node from the corresponding body stub, if this stub acts as spec,
   --  or to the N_Defining_Identifier node from the corresponding
   --  subprogram declaration. Otherwise the argument remains unchanged.

   function Corr_Decl_For_Stub (Stub_Node : Node_Id) return Node_Id;
   --  This function should be called only for N_Subprogram_Body_Stub
   --  nodes. If the corresponding subprogram body stub is a completion
   --  of some subprogram declaration, the functions returns the node
   --  representing this subprogram declaration, otherwise it returns
   --  the Empty node.

   function Is_Anonymous (E : Entity_Kind) return Boolean;
   --  Check if E corresponds to an anonymous access type or subtype.

   function Is_Predefined (Def_Op : Node_Id) return Boolean;
   --  Returns True if Def_Op is N_Defining_Operator_Symbol representing
   --  a predefined operation. Returns False otherwise.
   --  ??? May be, there is something like this in GNAT???

   function Is_Impl_Neq (Def_Op : Entity_Id) return Boolean;
   --  Checks if the argument if the entity of implicit "/=" that is defined
   --  for explicit user-defined "="

   function Is_From_Instance (Node : Node_Id) return Boolean;
   --  Checks if Node is from expanded generic template

   function Is_From_Rewritten_Aggregate (Node : Node_Id) return Boolean;
   --  Checks if Node is an N_Component_Association node belonging to a
   --  rewritten tree structure corresponding to some aggregate. Returns False
   --  if Node is not of N_Component_Association kind.

   function Is_Name_Of_Expanded_Subprogram (Node : Node_Id) return Boolean;
   --  Detects if the argument is a defining name from an expanded subprogram
   --  instantiation, In this case the front-end creates an artificial
   --  defining identifier node that is not Comes_From_Source, but that also
   --  does not have an instantiation chain in Sloc, so ASIS can get confused
   --  with this node and treat is as an implicit node if apply the usual
   --  tests to it. (See G312-006).

   function Is_From_Unknown_Pragma (Node : Node_Id) return Boolean;
   --  Checks if Node belongs to a subtree rooted  by unknown pragma. The tree
   --  structures for unknown pragmas are very poorly decorated, so semantic
   --  queries may just blow up when applied to elements representing
   --  components of such pragmas.

   function Get_Actual_Type_Name (Type_Mark_Node : Node_Id) return Node_Id;
   --  This function supposes, that its argument is of N_Identifier kind.
   --  When applied to a reference to an implicit subtype created in
   --  expanded generic instantiation as a way to pass the actual type,
   --  this function "unwinds" this implicit subtyping and returns the
   --  reference to the actual type. Otherwise it returns its argument
   --  unchanged.
   --  The case when the actual type is a derived type is treated specially -
   --  in this case "unwinding" could bring the internal type created by the
   --  front-end, so we break this unwinding and return the entity (!!!) node
   --  of the corresponding actual type.

   function Get_Instance_Name (Int_Name : Node_Id) return Node_Id;
   --  For Int_Node which should be Is_Generic_Instance (otherwise it is an
   --  error to use this function) and which denotes the entity declared in
   --  an artificial package created by the compiler for a generic
   --  instantiation, it finds an entity defined in a generic instantiation

   function Get_Derived_Type
     (Type_Entity     : Entity_Id;
      Inherited_Subpr : Entity_Id)
      return            Entity_Id;
   --  This function supposes that Type_Entity is a type entity,
   --  and Inherited_Subpr is the defining name of implicit inherited
   --  subprogram. It checks if Type_Entity is an ancestor type for the
   --  derived type which inherits Inherited_Subpr, and if it is, returns
   --  the entity of the derived type, otherwise returns Type_Entity

   function Is_Derived_Rep_Item
     (Type_Entity : Entity_Id;
      Rep_Item :    Node_Id)
      return        Boolean;
   --  Supposing that Type_Entity is an entity of some type, and Rep_Item
   --  represents  some representation item from the chain of representation
   --  items associated with this type, this function checks it Type_Entity
   --  derives this Rep_Item from some of its parent types.

   function Is_Artificial_Protected_Op_Item_Spec
     (E :    Entity_Id)
      return Boolean;
   --  Checks if E represents the entity from the artificial subprogram spec
   --  created by the compiler for some protected_operation_item which does not
   --  have a separate spec in the source code.
   --  Note that this function check protected operation entity and entities of
   --  its formal parameters (At some point we should rename it as
   --  Is_FROM_Artificial_Protected_Op_Item_Spec)

   function Represents_Class_Wide_Type_In_Instance
     (N    : Node_Id)
      return Boolean;
   --  Test function used to check if from the ASIS viewpoint the argument may
   --  represent the 'Class attribute reference corresponding to the actual
   --  class-wide type in the instantiation (see F410-011 for full details)

   function Represents_Base_Type_In_Instance (N : Node_Id) return Boolean;
   --  Test function used to check if from the ASIS viewpoint the argument may
   --  represent the 'Base attribute reference corresponding to the actual
   --  type in the instantiation.

   function Pass_Generic_Actual (N : Node_Id) return Boolean;
   --  Checks if N represents an artificial (created by the front-end)
   --  declaration used to pass the actual in the instantiation. The problem
   --  here is that for such declarations the Sloc field not always (and not
   --  for all of their subcomponents) points to the instantiation chain.

   function Part_Of_Pass_Generic_Actual (N : Node_Id) return Boolean;
   --  This function checks if its argument is a subcomponent of the construct
   --  for that Pass_Generic_Actual returns True. The only reason to have these
   --  two function instead of just this one is performance.

   function Explicit_Parent_Subprogram (E : Entity_Id) return Entity_Id;
   --  Provided that E points to an inherited subprogram, this function
   --  computes the entity of the corresponding explicitly defined parent
   --  subprogram.

   function Get_Importing_Pragma (E : Entity_Id) return Node_Id;
   --  Supposing that E is an Is_Imported Entity node, compute the
   --  corresponding Import or Interface pragma.

   function Is_Applied_To
     (Pragma_Node : Node_Id;
      Entity_Node : Entity_Id)
      return        Boolean;
   --  Supposing that Pragma_Node denotes a pragma, and Entity_Node is an
   --  entity node (the caller is responsible for this), checks if the pragma
   --  is applied to the entity.

end A4G.A_Sem;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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.
-----------------------------------------------------------------------

package body MAT.Consoles is

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Types.Hex_Image (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

end MAT.Consoles;

Implement the Print_Field procedure for addresses


-----------------------------------------------------------------------
--  wiki-filters-variables -- Expand variables in text and links
--  Copyright (C) 2020 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.
-----------------------------------------------------------------------

package body Wiki.Filters.Variables is

   function Need_Expand (Text : in Wiki.Strings.WString) return Boolean is
   begin
      return Wiki.Strings.Index (Text, "$") > 0;
   end Need_Expand;

   procedure Add_Variable (Chain : in Wiki.Filters.Filter_Chain;
                           Name  : in Wiki.Strings.WString;
                           Value : in Wiki.Strings.WString) is
      Filter : Filter_Type_Access := Chain.Next;
   begin
      while Filter /= null loop
         if Filter.all in Variable_Filter'Class then
            Variable_Filter'Class (Filter.all).Add_Variable (Name, Value);
            return;
         end if;
         Filter := Filter.Next;
      end loop;
   end Add_Variable;

   --  ------------------------------
   --  Add a variable to replace the given name by its value.
   --  ------------------------------
   procedure Add_Variable (Filter : in out Variable_Filter;
                           Name   : in Wiki.Strings.WString;
                           Value  : in Wiki.Strings.WString) is
   begin
      Filter.Variables.Include (Name, Value);
   end Add_Variable;

   procedure Add_Variable (Filter : in out Variable_Filter;
                           Name   : in String;
                           Value  : in Wiki.Strings.WString) is
   begin
      Filter.Variables.Include (Wiki.Strings.To_WString (Name), Value);
   end Add_Variable;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   overriding
   procedure Add_Header (Filter    : in out Variable_Filter;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      if Need_Expand (Header) then
         Filter_Type (Filter).Add_Header (Document, Filter.Expand (Header), Level);
      else
         Filter_Type (Filter).Add_Header (Document, Header, Level);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Add a text content with the given format to the document.  Replace variables
   --  that are contained in the text.
   --  ------------------------------
   overriding
   procedure Add_Text (Filter    : in out Variable_Filter;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map) is
   begin
      if Need_Expand (Text) then
         Filter_Type (Filter).Add_Text (Document, Filter.Expand (Text), Format);
      else
         Filter_Type (Filter).Add_Text (Document, Text, Format);
      end if;
   end Add_Text;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Variable_Filter;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Need_Expand (Name) then
         Filter_Type (Filter).Add_Link (Document, Filter.Expand (Name), Attributes);
      else
         Filter_Type (Filter).Add_Link (Document, Name, Attributes);
      end if;
   end Add_Link;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   overriding
   procedure Add_Quote (Filter     : in out Variable_Filter;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Need_Expand (Name) then
         Filter_Type (Filter).Add_Quote (Document, Filter.Expand (Name), Attributes);
      else
         Filter_Type (Filter).Add_Quote (Document, Name, Attributes);
      end if;
   end Add_Quote;

   --  ------------------------------
   --  Expand the variables contained in the text.
   --  ------------------------------
   function Expand (Filter : in Variable_Filter;
                    Text   : in Wiki.Strings.WString) return Wiki.Strings.WString is
      First      : Natural := Text'First;
      Pos        : Natural;
      Last       : Natural;
      Name_Start : Natural;
      Name_End   : Natural;
      Result     : Wiki.Strings.BString (256);
      Item       : Variable_Cursor;
      Match_End  : Wiki.Strings.WChar;
   begin
      while First <= Text'Last loop
         Pos := First;
         while Pos <= Text'Last and then Text (Pos) /= '$' loop
            Pos := Pos + 1;
         end loop;
         exit when Pos >= Text'Last;
         Strings.Wide_Wide_Builders.Append (Result, Text (First .. Pos - 1));
         First := Pos;
         Name_Start := Pos + 1;
         if Text (Name_Start) = '(' or Text (Name_Start) = '{' then
            Match_End := (if Text (Name_Start) = '(' then ')' else '}');
            Name_Start := Name_Start + 1;
            Name_End := Name_Start;
            while Name_End <= Text'Last and then Text (Name_End) /= Match_End loop
               Name_End := Name_End + 1;
            end loop;
            exit when Name_End > Text'Last;
            exit when Text (Name_End) /= Match_End;
            Last := Name_End + 1;
            Name_End := Name_End - 1;
         else
            Name_End := Name_Start;
            while Name_End <= Text'Last and then Text (Name_End) /= ' ' loop
               Name_End := Name_End + 1;
            end loop;
            Last := Name_End;
            Name_End := Name_End - 1;
         end if;
         Item := Filter.Variables.Find (Text (Name_Start .. Name_End));
         if Variable_Maps.Has_Element (Item) then
            Strings.Wide_Wide_Builders.Append (Result, Variable_Maps.Element (Item));
         elsif Last > Text'Last then
            exit;
         else
            Strings.Wide_Wide_Builders.Append (Result, Text (First .. Last));
         end if;
         First := Last;
      end loop;
      if First <= Text'Last then
         Strings.Wide_Wide_Builders.Append (Result, Text (First .. Text'Last));
      end if;
      return Strings.Wide_Wide_Builders.To_Array (Result);
   end Expand;

end Wiki.Filters.Variables;

Implement the variables filter to replace variables in wiki text


-----------------------------------------------------------------------
--  druss-commands -- Commands available for Druss
--  Copyright (C) 2017 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.Text_IO;
with Ada.Strings.Unbounded;
with Util.Properties;
with Druss.Gateways;
package body Druss.Commands.Bboxes is

   use Ada.Strings.Unbounded;
   use Ada.Text_IO;

   procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
   begin
      Gateway.Refresh;
      Put (To_String (Gateway.Ip));
      Set_Col (30);
      Put (Gateway.Wan.Get ("wan.internet.state", "?"));
      Set_Col (38);
      Put (Gateway.Wan.Get ("wan.ip.address", "?"));
      Set_Col (60);
      Put (Gateway.Device.Get ("device.numberofboots", "-"));
      Set_Col (68);
      Put (Gateway.Device.Get ("device.uptime", "-"));
      New_Line;
   end Box_Status;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Util.Commands.Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Druss.Gateways.Iterate (Context.Gateways, Box_Status'Access);
   end Execute;

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
   begin
      Put_Line ("bbox: Operations to control the bbox");
      Put_Line ("Usage: druss bbox list");
      Put_Line ("       druss bbox add IP");
      Put_Line ("       druss bbox del IP");
   end Help;

end Druss.Commands.Bboxes;

Implement the bbox command

Implement the bbox command


-----------------------------------------------------------------------
--  wiki-plugins -- Wiki plugins
--  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.Attributes;
with Wiki.Documents;

--  == Plugins ==
--  The <b>Wiki.Plugins</b> package defines the plugin interface that is used by the wiki
--  engine to provide pluggable extensions in the Wiki.
--
package Wiki.Plugins is

   pragma Preelaborate;

   type Wiki_Plugin is limited interface;

   --  Expand the plugin configured with the parameters for the document.
   procedure Expand (Plugin   : in out Wiki_Plugin;
                     Document : in out Wiki.Documents.Document_Reader'Class;
                     Params   : in out Wiki.Attributes.Attribute_List_Type) is abstract;

end Wiki.Plugins;

Fix typo

Fix typo


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . A _ O S I N T                          --
--                                                                          --
--                                 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).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  The original idea of this package was to be an ASIS analog of the GNAT
--  Osint package and to contain the low-level routines needed by different
--  components of the ASIS implementation. But its current version contains a
--  very few routines, so probably we should merge this package with some
--  other ASIS implementation utility package.

with GNAT.OS_Lib; use GNAT.OS_Lib;
with Types;       use Types;

package A4G.A_Osint is

   function Normalize_Directory_Name
     (Directory : String)
      return String;
   --  Verify and normalize a directory name. If directory name is invalid,
   --  this will return an empty string (not implemented for now -  all the
   --  checks should be made by a caller). Otherwise it will insure a
   --  trailing directory separator and make other normalizations.

   function Get_Max_File_Name_Length return Int;
   --  yields the maximum file name length for system. Returns Int'Last,
   --  if the system does not limit the maximum file name length.

   procedure Free_Argument_List (List : in out Argument_List_Access);
   --  if List is not null, frees the memory occupied by its content

end A4G.A_Osint;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  locales.tests -- Unit tests for locales
--  Copyright (C) 2009, 2010, 2011 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;
package body Util.Locales.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Locale",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Language",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Country",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Variant",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Hash",
                       Test_Hash_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.=",
                       Test_Compare_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Locales",
                       Test_Get_Locales'Access);
   end Add_Tests;

   procedure Test_Get_Locale (T : in out Test) is
      Loc : Locale;
   begin
      Loc := Get_Locale ("en");
      Assert_Equals (T, "en", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("ja", "JP", "JP");
      Assert_Equals (T, "ja", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "JP", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "JP", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("no", "NO", "NY");
      Assert_Equals (T, "no", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "NO", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "NY", Get_Variant (Loc), "Invalid variant");
   end Test_Get_Locale;

   procedure Test_Hash_Locale (T : in out Test) is
      use type Ada.Containers.Hash_Type;
   begin
      T.Assert (Hash (FRANCE) /= Hash (FRENCH), "Hash should be different");
      T.Assert (Hash (FRANCE) /= Hash (ENGLISH), "Hash should be different");
      T.Assert (Hash (FRENCH) /= Hash (ENGLISH), "Hash should be different");
   end Test_Hash_Locale;

   procedure Test_Compare_Locale (T : in out Test) is
   begin
      T.Assert (FRANCE /= FRENCH, "Equality");
      T.Assert (FRANCE = FRANCE, "Equality");
      T.Assert (FRANCE = Get_Locale ("fr", "FR"), "Equality");
      T.Assert (FRANCE /= ENGLISH, "Equality");
      T.Assert (FRENCH /= ENGLISH, "Equaliy");
   end Test_Compare_Locale;

   procedure Test_Get_Locales (T : in out Test) is
   begin
      for I in Locales'Range loop
         declare
            Language : constant String := Get_Language (Locales (I));
            Country  : constant String := Get_Country (Locales (I));
            Variant  : constant String := Get_Variant (Locales (I));
            Loc      : constant Locale := Get_Locale (Language, Country, Variant);
            Name     : constant String := To_String (Loc);
         begin
            T.Assert (Loc = Locales (I), "Invalid locale at " & Positive'Image (I)
                      & " " & Loc.all);
            if Variant'Length > 0 then
               Assert (T, Name, Language & "_" & Country & "_" & Variant, "Invalid To_String");
            elsif Country'Length > 0 then
               Assert (T, Name, Language & "_" & Country, "Invalid To_String");
            else
               Assert (T, Name, Language, "Invalid To_String");
            end if;
         end;
      end loop;
   end Test_Get_Locales;

end Util.Locales.Tests;

-----------------------------------------------------------------------
--  locales.tests -- Unit tests for locales
--  Copyright (C) 2009, 2010, 2011 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;
package body Util.Locales.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Locale",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Language",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Country",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Variant",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Hash",
                       Test_Hash_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.=",
                       Test_Compare_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Locales",
                       Test_Get_Locales'Access);
   end Add_Tests;

   procedure Test_Get_Locale (T : in out Test) is
      Loc : Locale;
   begin
      Loc := Get_Locale ("en");
      Assert_Equals (T, "en", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("ja", "JP", "JP");
      Assert_Equals (T, "ja", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "JP", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "JP", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("no", "NO", "NY");
      Assert_Equals (T, "no", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "NO", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "NY", Get_Variant (Loc), "Invalid variant");
   end Test_Get_Locale;

   procedure Test_Hash_Locale (T : in out Test) is
      use type Ada.Containers.Hash_Type;
   begin
      T.Assert (Hash (FRANCE) /= Hash (FRENCH), "Hash should be different");
      T.Assert (Hash (FRANCE) /= Hash (ENGLISH), "Hash should be different");
      T.Assert (Hash (FRENCH) /= Hash (ENGLISH), "Hash should be different");
   end Test_Hash_Locale;

   procedure Test_Compare_Locale (T : in out Test) is
   begin
      T.Assert (FRANCE /= FRENCH, "Equality");
      T.Assert (FRANCE = FRANCE, "Equality");
      T.Assert (FRANCE = Get_Locale ("fr", "FR"), "Equality");
      T.Assert (FRANCE /= ENGLISH, "Equality");
      T.Assert (FRENCH /= ENGLISH, "Equaliy");
   end Test_Compare_Locale;

   procedure Test_Get_Locales (T : in out Test) is
   begin
      for I in Locales'Range loop
         declare
            Language : constant String := Get_Language (Locales (I));
            Country  : constant String := Get_Country (Locales (I));
            Variant  : constant String := Get_Variant (Locales (I));
            Loc      : constant Locale := Get_Locale (Language, Country, Variant);
            Name     : constant String := To_String (Loc);
         begin
            T.Assert (Loc = Locales (I), "Invalid locale at " & Positive'Image (I)
                      & " " & Loc.all);
            if Variant'Length > 0 then
               Assert_Equals (T, Name, Language & "_" & Country & "_" & Variant,
                              "Invalid To_String");
            elsif Country'Length > 0 then
               Assert_Equals (T, Name, Language & "_" & Country, "Invalid To_String");
            else
               Assert_Equals (T, Name, Language, "Invalid To_String");
            end if;
         end;
      end loop;
   end Test_Get_Locales;

end Util.Locales.Tests;

Fix compilation with GNAT 2011

Fix compilation with GNAT 2011


-----------------------------------------------------------------------
--  gen-artifacts-docs -- Artifact for documentation
--  Copyright (C) 2012 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.Files;
with Util.Log.Loggers;

with Ada.Directories;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Characters.Handling;

with DOM.Core;
with Gen.Model.Packages;

package body Gen.Artifacts.Docs is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Docs");

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   procedure Read_Ada_File (File   : in String;
                            Result : in out File_Document);

   procedure Scan_Files (Path : in String;
                         Docs : in out Doc_Maps.Map);

   procedure Generate (Docs : in Doc_Maps.Map);

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is
   begin
      null;
   end Initialize;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class) is
      Docs : Doc_Maps.Map;
   begin
      Scan_Files ("src", Docs);
      Generate (Docs);
   end Prepare;

   procedure Generate (Source : in String;
                       Doc    : in File_Document) is
      use type Ada.Containers.Count_Type;

      Name : constant String := Ada.Strings.Unbounded.To_String (Doc.Name) & ".wiki";
      Path : String := Util.Files.Compose ("doc", Name);
      File : Ada.Text_IO.File_Type;
      Iter : Line_Vectors.Cursor := Doc.Lines.First;

      procedure Write (Line : in Line_Type) is
      begin
         Ada.Text_IO.Put_Line (File, Line.Content);
      end Write;

   begin
      if Doc.Lines.Length = 0 then
         return;
      end if;
      Ada.Directories.Create_Path ("doc");

      Ada.Text_IO.Create (File => File,
                          Mode => Ada.Text_IO.Out_File,
                          Name => Path);
      while Line_Vectors.Has_Element (Iter) loop
         Line_Vectors.Query_Element (Iter, Write'Access);
         Line_Vectors.Next (Iter);
      end loop;
      Ada.Text_IO.Close (File);
   end Generate;

   procedure Generate (Docs : in Doc_Maps.Map) is
      Iter : Doc_Maps.Cursor := Docs.First;
   begin
      while Doc_Maps.Has_Element (Iter) loop
         Doc_Maps.Query_Element (Iter, Generate'Access);
         Doc_Maps.Next (Iter);
      end loop;
   end Generate;

   procedure Scan_Files (Path : in String;
                         Docs : in out Doc_Maps.Map) is
      use Ada.Directories;

      Filter  : constant Filter_Type := (Ordinary_File => True,
                                         Directory     => True,
                                         others        => False);
      Ent     : Ada.Directories.Directory_Entry_Type;
      Search  : Search_Type;

   begin

      Start_Search (Search, Directory => Path,
                    Pattern => "*.ads", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Name      : constant String := Simple_Name (Ent);
            Full_Path : constant String := Ada.Directories.Full_Name (Ent);
            Doc       : File_Document;
         begin
            Log.Debug ("Collect {0}", Full_Path);

            Read_Ada_File (Full_Path, Doc);
            Docs.Include (Name, Doc);
         end;
      end loop;
   end Scan_Files;

   --  ------------------------------
   --  Returns True if the line indicates a bullet or numbered list.
   --  ------------------------------
   function Is_List (Line : in String) return Boolean is
   begin
      if Line'Length <= 3 then
         return False;
      else
         return Line (Line'First + 2) = '*';
      end if;
   end Is_List;

   --  ------------------------------
   --  Returns True if the line indicates a code sample.
   --  ------------------------------
   function Is_Code (Line : in String) return Boolean is
   begin
      if Line'Length <= 3 then
         return False;
      else
         return Line (Line'First) =  ' ' and Line (Line'First + 1) = ' ';
      end if;
   end Is_Code;

   --  ------------------------------
   --  Append a raw text line to the document.
   --  ------------------------------
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String) is
   begin
      Doc.Lines.Append (Line_Type '(Len => Line'Length, Content => Line));
   end Append_Line;

   --  ------------------------------
   --  Analyse the documentation line and collect the documentation text.
   --  ------------------------------
   procedure Append (Doc   : in out File_Document;
                     Line  : in String) is
   begin
      case Doc.State is
         when IN_PARA =>
            if Line'Length = 0 then
               Doc.State := IN_SEPARATOR;

            elsif Is_List (Line) then
               Doc.State := IN_LIST;
            end if;

         when IN_SEPARATOR =>
            if Is_List (Line) then
               Doc.State := IN_LIST;

            elsif Is_Code (Line) then
               Doc.State := IN_CODE;
               Append_Line (Doc, "{{{");
            end if;

         when IN_CODE =>
            if Line'Length = 0 then
               Doc.State := IN_CODE_SEPARATOR;
               return;
            end if;

         when IN_CODE_SEPARATOR =>
            if Line'Length > 0 and then Ada.Characters.Handling.Is_Letter (Line (Line'First)) then
               Append_Line (Doc, "}}}");
               Append_Line (Doc, "");
               Doc.State := IN_PARA;
            end if;

         when IN_LIST =>
            if Line'Length = 0 then
               Doc.State := IN_SEPARATOR;
            end if;
      end case;
      Append_Line (Doc, Line);
   end Append;

   --  ------------------------------
   --  Set the name associated with the document extract.
   --  ------------------------------
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String) is
      S1 : String := Ada.Strings.Fixed.Trim (Name, Ada.Strings.Both);
   begin
      for I in S1'Range loop
         if S1 (I) = '.' then
            S1 (I) := '_';
         end if;
      end loop;
      Doc.Name := Ada.Strings.Unbounded.To_Unbounded_String (S1);
   end Set_Name;

   procedure Read_Ada_File (File   : in String;
                            Result : in out File_Document) is
      procedure Process (Line : in String);

      Done              : Boolean := False;
      Doc_Block         : Boolean := False;

      procedure Process (Line : in String) is
      begin
         if Done then
            return;

         elsif Line'Length <= 1 then
            Doc_Block := False;

         elsif Line (Line'First) = '-' and Line (Line'First + 1) = '-' then
            if Doc_Block then
               if Line'Length < 4 then
                  Append (Result, "");

               elsif Line (Line'First + 2) = ' ' and Line (Line'First + 3) = ' ' then
                  Append (Result, Line (Line'First + 4 .. Line'Last));
               end if;
            elsif Line'Length >= 7 and then Line (Line'First .. Line'First + 6) = "--  == " then
               Doc_Block := True;
               Append (Result, Line (Line'First + 4 .. Line'Last));
            end if;

         else
            declare
               Pos  : Natural := Ada.Strings.Fixed.Index (Line, "package");
               Last : Natural;
            begin
               if Pos > 0 then
                  Done := True;
                  Pos := Ada.Strings.Fixed.Index (Line, " ", Pos);
                  if Pos > 0 then
                     Last := Ada.Strings.Fixed.Index (Line, " ", Pos + 1);
                     Set_Name (Result,  Line (Pos .. Last));
                  end if;
               end if;
            end;

         end if;
      end Process;
   begin
      Util.Files.Read_File (File, Process'Access);
   end Read_Ada_File;

end Gen.Artifacts.Docs;

Implement the documentation artifact - Scan the Ada specification files - Read and extract the documentation before the Ada specificaton


-----------------------------------------------------------------------
--  util-http-headers -- HTTP Headers
--  Copyright (C) 2022 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.Fixed;

with Util.Strings.Tokenizers;
package body Util.Http.Headers is

   --  Split an accept like header into multiple tokens and a quality value.
   --  Invoke the `Process` procedure for each token.  Example:
   --
   --     Accept-Language: de, en;q=0.7, jp, fr;q=0.8, ru
   --
   --  The `Process` will be called for "de", "en" with quality 0.7,
   --  and "jp", "fr" with quality 0.8 and then "ru" with quality 1.0.
   procedure Split_Header (Header  : in String;
                           Process : access procedure (Item    : in String;
                                                       Quality : in Quality_Type)) is
      use Util.Strings;
      procedure Process_Token (Token : in String;
                               Done  : out Boolean);

      Quality : Quality_Type := 1.0;

      procedure Process_Token (Token : in String;
                               Done  : out Boolean) is
         Name : constant String := Ada.Strings.Fixed.Trim (Token, Ada.Strings.Both);
      begin
         Process (Name, Quality);
         Done := False;
      end Process_Token;

      Q, N, Pos  : Natural;
      Last    : Natural := Header'First;
   begin
      while Last < Header'Last loop
         Quality := 1.0;
         Pos := Index (Header, ';', Last);
         if Pos > 0 then
            N := Index (Header, ',', Pos);
            if N = 0 then
               N := Header'Last + 1;
            end if;
            Q := Pos + 1;
            while Q < N loop
               if Header (Q .. Q + 1) = "q=" then
                  begin
                     Quality := Quality_Type'Value (Header (Q + 2 .. N - 1));
                  exception
                     when others =>
                        null;
                  end;
                  exit;

               elsif Header (Q) /= ' ' then
                  exit;

               end if;
               Q := Q + 1;
            end loop;

            Util.Strings.Tokenizers.Iterate_Tokens (Content => Header (Last .. Pos - 1),
                                                    Pattern => ",",
                                                    Process => Process_Token'Access);
            Last := N + 1;
         else
            Util.Strings.Tokenizers.Iterate_Tokens (Content => Header (Last .. Header'Last),
                                                    Pattern => ",",
                                                    Process => Process_Token'Access);
            return;
         end if;
      end loop;
   end Split_Header;

end Util.Http.Headers;

Add Split_Header (moved from Ada Server Faces)


------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--      A S I S . C O M P I L A T I O N _ U N I T S . R E L A T I O N S     --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--           Copyright (c) 2006, Free Software Foundation, Inc.             --
--                                                                          --
-- This   specification  is  adapted   from  the  Ada   Semantic  Interface --
-- Specification Standard (ISO/IEC 15291) for use with GNAT.  In accordance --
-- with the copyright of that document, you can freely copy and modify this --
-- specification, provided that if you redistribute a modified version, any --
-- changes  that  you have made are clearly indicated. The copyright notice --
-- above,  and  the  license  provisions  that  follow  apply solely to the --
-- contents of the part following the private keyword.                      --
--                                                                          --
-- 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  12 package Asis.Compilation_Units.Relations
------------------------------------------------------------------------------
------------------------------------------------------------------------------
package Asis.Compilation_Units.Relations is
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  Asis.Compilation_Units.Relations encapsulates semantic relationship
--  concepts used in ASIS.
------------------------------------------------------------------------------
--  12.1  type Relationship
------------------------------------------------------------------------------
--  Relationship queries provide references to compilation units that are
--  related, in some specific fashion, to one or more given compilation units.
--  Compilation units located by these queries are returned as a set of
--  ordered lists.

   type Relationship
     (Consistent_Length   : Asis.ASIS_Natural;
      Inconsistent_Length : Asis.ASIS_Natural;
      Missing_Length      : Asis.ASIS_Natural;
      Circular_Length     : Asis.ASIS_Natural)
   is
      record
         Consistent   : Asis.Compilation_Unit_List (1 .. Consistent_Length);
         Inconsistent : Asis.Compilation_Unit_List (1 .. Inconsistent_Length);
         Missing      : Asis.Compilation_Unit_List (1 .. Missing_Length);
         Circular     : Asis.Compilation_Unit_List (1 .. Circular_Length);
      end record;

--  The following describes the semantics of the unit lists returned by the
--  queries Semantic_Dependence_Order and Elaboration_Order:
--
--  Each query returns a set of four lists.  Every unit returned will have the
--  same Enclosing_Context.  The lists are:
--
--    a) (Consistent)   A list of consistent ordered units.
--    b) (Inconsistent) A list of units that are inconsistent with one or
--                      more units on which they semantically depend.
--    c) (Missing)      A list of units that have missing (nonexistent) related
--                      units.
--    d) (Circular)     A list of circular semantic dependencies between units.
--
--
--  a) The consistent units list:
--
--     The semantics for the ordering of units in the first list are defined by
--     the individual queries.
--
--     Every unit in this list is unique.  No duplicates are returned; no
--     two units in the list are Is_Equal or Is_Identical.
--
--  b) The inconsistent units list:
--
--     The second list is made up of unit pairs.
--
--     Each pairing defines an inconsistent semantic dependence relationship.
--     The right unit of each pair semantically depends on the preceding left
--     unit. All rightmost units of each pair are always inconsistent, and will
--     not appear in the consistent units list. The leftmost unit can be either
--     consistent or inconsistent. If a leftmost units is consistent, then it
--     also appears in the consistent units list; otherwise the unit is part of
--     an inconsistent transitive relationship.
--
--     The unit pairs are ordered such that there are no forward semantic
--     dependencies between the inconsistent units.  Each inconsistent unit's
--     supporters always precede it in the list.
--
--     As an example, given four units, A withs B, B withs C, and C withs D;
--     if D is replaced, the inconsistent list contains six units with the
--     three pairs:
--
--        DC  CB  BA
--
--     The list indicates that units C, B, and A are inconsistent (the
--     rightmost units of each pair). Semantic dependencies such as B depends
--     on C also are indicated. The units C, B, and A are in an order that
--     could be submitted to the compiler (a possible recompilation order).
--
--     If a unit is inconsistent because the source for the unit has been
--     edited (or otherwise been made inconsistent by some action of the user
--     or implementation) then the unit references Nil_Compilation_Unit as the
--     cause of the inconsistency (e.g., (Nil A Nil B) is a list of two
--     inconsistent units, neither of which can point to a third unit as the
--     cause for their being inconsistent).
--
--  --|IP An implementation is allowed to use Nil_Compilation_Unit value for
--  --|IP the first unit of each pair if it cannot determine the supporting
--  --|IP unit causing the inconsistent semantic dependence.
--
--     For the above example, the list returned is:
--
--           DC DB DA CB CA BA
--
--     This list reports all dependencies:
--
--           D withed by C withed by B withed by A => DC DB DA
--                       C withed by B withed by A => CB CA
--                                   B withed by A => BA
--
--  c) The missing dependence list:
--
--     The third list is made up of unit pairs.   Each pairing consists of a
--     unit followed by a missing related unit needed by the first unit.
--     A missing unit is a required Compilation_Unit, with a known name, with a
--     Unit_Kind that is either A_Nonexistent_Declaration or
--     A_Nonexistent_Body.
--
--     For example:
--
--     Given a list containing the units:  AB AC
--
--     If Unit_Kind(B) = A_Nonexistent_Declaration and
--        Unit_Kind(C) = A_Nonexistent_Body then
--
--     It can be deduced that:
--        A is missing a needed supporter B (A depends semantically on B).
--        A is missing a needed related unit body C
--        (depending on the kind for A, C can be A's required body or some
--         subunit of A)
--
--     A unit is reported as missing only if the Post-Compilation Rules of Ada
--     determine it to be needed.  Reference Manual 10.2.
--
--  d) The circular dependence list:
--
--     Circular dependencies between compilation units are provided in the
--     fourth list.  There may be more than one set of circular dependencies.
--     The ordering of distinct sets in the list is implementation-defined.
--     This list will never contain nonexistent units.
--
--     The list is made up of unit pairs.  The second unit of each pair depends
--     semantically on the first unit.  A circularity is established when the
--     first unit of a pair also appears as the second unit of a later pair.
--     (See the unit A in the example below; it is the first unit of the first
--     pair and is the second unit of the third pair). The next set of circular
--     dependent units, if any, starts with the next unit in the list (the unit
--     D in the example below).
--
--     For example:
--
--     Given a list containing the units:  AC CB BA DG GF FE ED
--
--     It can be determined that there are two sets of circularly dependent
--     units:
--        {A, B, C} and {D, E, F, G}
--
--     The dependencies are:  A depends on B, B depends on C, C depends on A.
--            D depends on E, E depends on F, F depends on G, G depends on D.
--
--     Each circle of dependence is reported exactly once.  It is not reported
--     once for each unit in the circle.
--
------------------------------------------------------------------------------
--  12.2  constant Nil_Relationship
------------------------------------------------------------------------------

   Nil_Relationship : constant Relationship :=
           (Consistent_Length   => 0,
            Inconsistent_Length => 0,
            Missing_Length      => 0,
            Circular_Length     => 0,
            Consistent          => Asis.Nil_Compilation_Unit_List,
            Inconsistent        => Asis.Nil_Compilation_Unit_List,
            Missing             => Asis.Nil_Compilation_Unit_List,
            Circular            => Asis.Nil_Compilation_Unit_List);

------------------------------------------------------------------------------
--  12.3  function Semantic_Dependence_Order
------------------------------------------------------------------------------
--  Semantic Dependence Relationships    - Reference Manual 10.1.1(24).
--  Elaboration Dependence Relationships - Reference Manual 10.1.1(25).
--
--  --|AN Application Note:
--  --|AN
--  --|AN To properly determine unit consistency, use one of the two semantic
--  --|AN dependence queries: Elaboration_Order or Semantic_Dependence_Order.
--  --|AN These queries return a value of the type Relationship, which contains
--  --|AN lists of consistent, inconsistent, missing and circular units.
--  --|AN
--  --|AN For these two queries, the existence of units in one or more of the
--  --|AN inconsistent, missing, or circular units list means that the
--  --|AN consistent unit list may not be complete.
--  --|AN
--  --|AN Applications that do not check for inconsistent, missing, or circular
--  --|AN units before using the consistent list might not operate as expected.
--  --|AN
------------------------------------------------------------------------------

   function Semantic_Dependence_Order
               (Compilation_Units : Asis.Compilation_Unit_List;
                Dependent_Units   : Asis.Compilation_Unit_List;
                The_Context       : Asis.Context;
                Relation          : Asis.Relation_Kinds)
               return               Relationship;

------------------------------------------------------------------------------
--  Compilation_Units   - Specifies a list of pertinent units
--  Dependent_Units     - Specifies dependents used to limit the query
--  The_Context         - Specifies a program Context for context
--  Relation            - Specifies the relationship to query
--
--  Produces a Relationship value containing compilation_unit elements related
--  to the given Compilation_Units by the specified relation.
--
--  The compilation_unit elements in the consistent units list are ordered such
--  that there are no forward semantic dependencies.
--
--  Dependent_Units are ignored unless the Relation is Descendants or
--  Dependents.  The union of units in the needed units of the Dependent_Units
--  list provide a limiting context for the query.  Only members of these
--  needed units are present in the result.
--
--  If the Dependent_Units list is Is_Nil, the context for the search is the
--  entire Context.  The result of such a query is the full (unlimited)
--  list of Dependents for the Compilation_Units.
--
--  All units in the result will have an Enclosing_Context value that
--  Is_Identical to The_Context.
--

--  Appropriate Unit_Kinds:
--       A_Procedure
--       A_Function
--       A_Package
--       A_Generic_Procedure
--       A_Generic_Function
--       A_Generic_Package
--       A_Procedure_Instance
--       A_Function_Instance
--       A_Package_Instance
--       A_Procedure_Renaming
--       A_Function_Renaming
--       A_Package_Renaming
--       A_Generic_Procedure_Renaming
--       A_Generic_Function_Renaming
--       A_Generic_Package_Renaming
--       A_Procedure_Body
--       A_Function_Body
--       A_Package_Body
--       A_Procedure_Body_Subunit
--       A_Function_Body_Subunit
--       A_Package_Body_Subunit
--       A_Task_Body_Subunit
--       A_Protected_Body_Subunit
--       An_Unknown_Unit            -- See Implementation Permissions
--
--  The Semantic_Dependence_Order query should never raise an exception
--  when processing inconsistent unit (sub)sets.  This query is the only
--  means for an application to know if a given unit is consistent with
--  (some of) its supporters (dependents), and therefore the related
--  semantic processing can give valuable results for this unit.
--
--  --|IP Implementation Permissions:
--  --|IP
--  --|IP The handling of An_Unknown_Unit is implementation specific. It can be
--  --|IP possible to obtain Semantic Dependence Relationships when starting
--  --|IP with a list containing one or more units that are An_Unknown_Unit.
--  --|IP However, results may vary across ASIS implementations.
--  --|AN----------------------------------------------------------------------
--  --|AN Semantic_Dependence_Order defines consistent units to be ordered such
--  --|AN that there are no forward semantic dependencies.
--
------------------------------------------------------------------------------
--  12.4  function Elaboration_Order
------------------------------------------------------------------------------

   function Elaboration_Order
               (Compilation_Units : Asis.Compilation_Unit_List;
                The_Context       : Asis.Context)
               return               Relationship;

------------------------------------------------------------------------------
--  Compilation_Units   - Specifies a list of units to elaborate
--  The_Context         - Specifies a program Context for context
--
--  Produces, in elaboration order, a Relationship value containing compilation
--  units required to elaborate the given compilation units.
--
--  The return value contains the set of ordered lists described above for the
--  queries on Semantic Dependence Relationships.  If the inconsistent,
--  missing, and circular lists are empty, the consistent list will contain
--  all units required to elaborate the arguments.
--  --|IP
--  --|IP The Relationship value may include any number of
--  --|IP implementation-specific runtime support packages.
--
--  The first unit in the Consistent units list will always be the
--  specification for package Standard.  The list will contain all units
--  required to elaborate the arguments.
--
--  Use the Context_Clause_Elements query to get pragma Elaborate elements
--  for a compilation unit.
--
--  Appropriate Unit_Kinds:
--       A_Procedure
--       A_Function
--       A_Package
--       A_Generic_Procedure
--       A_Generic_Function
--       A_Generic_Package
--       A_Procedure_Instance
--       A_Function_Instance
--       A_Package_Instance
--       A_Procedure_Renaming
--       A_Function_Renaming
--       A_Package_Renaming
--       A_Generic_Procedure_Renaming
--       A_Generic_Function_Renaming
--       A_Generic_Package_Renaming
--       A_Procedure_Body
--       A_Function_Body
--       A_Package_Body
--       A_Procedure_Body_Subunit
--       A_Function_Body_Subunit
--       A_Package_Body_Subunit
--       A_Task_Body_Subunit
--       A_Protected_Body_Subunit
--       An_Unknown_Unit            -- See Implementation Permissions
--
--  --|IP Implementation Permissions:
--  --|IP
--  --|IP The handling of An_Unknown_Unit is implementation specific.  It can
--  --|IP be possible to obtain Semantic Dependence Relationships when starting
--  --|IP with a list containing one or more units that are An_Unknown_Unit.
--  --|IP However, results may vary across ASIS implementations.
--
------------------------------------------------------------------------------
end Asis.Compilation_Units.Relations;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  security-random -- Random numbers for nonce, secret keys, token generation
--  Copyright (C) 2017 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 Interfaces.C;
with Ada.Calendar;
with Ada.Calendar.Conversions;
with Util.Encoders.Base64;

package body Security.Random is

   use Interfaces;

   --  ------------------------------
   --  Initialize the random generator.
   --  ------------------------------
   overriding
   procedure Initialize (Gen : in out Generator) is
   begin
      Gen.Rand.Reset;
   end Initialize;

   --  ------------------------------
   --  Fill the array with pseudo-random numbers.
   --  ------------------------------
   procedure Generate (Gen  : in out Generator;
                       Into : out Ada.Streams.Stream_Element_Array) is
   begin
      Gen.Rand.Generate (Into);
   end Generate;

   --  ------------------------------
   --  Generate a random sequence of bits and convert the result
   --  into a string in base64url.
   --  ------------------------------
   function Generate (Gen  : in out Generator'Class;
                      Bits : in Positive) return String is
      use type Ada.Streams.Stream_Element_Offset;

      Rand_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset (4 * ((Bits + 31) / 32));

      Rand    : Ada.Streams.Stream_Element_Array (0 .. Rand_Count - 1);
      Buffer  : Ada.Streams.Stream_Element_Array (0 .. Rand_Count * 3);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      --  Generate the random sequence.
      Gen.Generate (Rand);

      --  Encode the random stream in base64url and save it into the result string.
      Encoder.Set_URL_Mode (True);
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);
      declare
         Result : String (1 .. Natural (Encoded + 1));
      begin
         for I in 0 .. Encoded loop
            Result (Natural (I + 1)) := Character'Val (Buffer (I));
         end loop;
         return Result;
      end;
   end Generate;

   --  ------------------------------
   --  Generate a random sequence of bits, convert the result
   --  into a string in base64url and append it to the buffer.
   --  ------------------------------
   procedure Generate (Gen  : in out Generator'Class;
                       Bits : in Positive;
                       Into : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type Ada.Streams.Stream_Element_Offset;

      Rand_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset (4 * ((Bits + 31) / 32));

      Rand    : Ada.Streams.Stream_Element_Array (0 .. Rand_Count - 1);
      Buffer  : Ada.Streams.Stream_Element_Array (0 .. Rand_Count * 3);
      Encoder : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      --  Generate the random sequence.
      Gen.Generate (Rand);

      --  Encode the random stream in base64url and save it into the result string.
      Encoder.Set_URL_Mode (True);
      Encoder.Transform (Data => Rand, Into => Buffer,
                         Last => Last, Encoded => Encoded);
      for I in 0 .. Encoded loop
         Ada.Strings.Unbounded.Append (Into, Character'Val (Buffer (I)));
      end loop;
   end Generate;

   --  Protected type to allow using the random generator by several tasks.
   protected body Raw_Generator is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;

         Size : constant Ada.Streams.Stream_Element_Offset := Into'Last / 4;
      begin
         --  Generate the random sequence.
         for I in 0 .. Size loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Rand);
            begin
               Into (4 * I)     := Stream_Element (Value and 16#0FF#);
               Into (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Into (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Into (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate;

      procedure Reset is
         Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         S    : constant Ada.Calendar.Day_Duration := Ada.Calendar.Seconds (Now);
         Sec  : Interfaces.C.long;
         Nsec : Interfaces.C.long;
      begin
         Ada.Calendar.Conversions.To_Struct_Timespec (S, Sec, Nsec);
         Id_Random.Reset (Rand, Integer (Unsigned_32 (Sec) xor Unsigned_32 (Nsec)));
      end Reset;

   end Raw_Generator;

end Security.Random;

Implement the random generator operations (taken from the OAuth client random generator)