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

with Util.Locales;
with Util.Dates.Formats;
with Util.Properties.Bundles;
with Util.Beans.Objects.Time;

with ASF.Locales;
with ASF.Utils;
with ASF.Applications.Main;
package body AWA.Converters.Dates is

   ONE_HOUR : constant Duration := 3600.0;
   ONE_DAY  : constant Duration := 24 * ONE_HOUR;

   --  ------------------------------
   --  Convert the object value into a string.  The object value is associated
   --  with the specified component.
   --  If the string cannot be converted, the Invalid_Conversion exception should be raised.
   --  ------------------------------
   overriding
   function To_String (Convert   : in Relative_Date_Converter;
                       Context   : in ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in ASF.Components.Base.UIComponent'Class;
                       Value     : in Util.Beans.Objects.Object) return String is
      Bundle  : ASF.Locales.Bundle;
      Locale  : constant Util.Locales.Locale := Context.Get_Locale;
   begin
      begin
         ASF.Applications.Main.Load_Bundle (Context.Get_Application.all,
                                            Name   => "dates",
                                            Locale => Util.Locales.To_String (Locale),
                                            Bundle => Bundle);

      exception
         when E : Util.Properties.Bundles.NO_BUNDLE =>
            Component.Log_Error ("Cannot localize dates: {0}",
                                 Ada.Exceptions.Exception_Message (E));
      end;

      --  Convert the value as a date here so that we can raise an Invalid_Conversion exception.
      declare
         use Ada.Calendar;

         Date    : constant Ada.Calendar.Time := Util.Beans.Objects.Time.To_Time (Value);
         Now     : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Dt      : constant Duration := Now - Date;
         Values  : ASF.Utils.Object_Array (1 .. 1);
         Result  : Ada.Strings.Unbounded.Unbounded_String;
      begin
         if Dt < 60.0 then
            return Bundle.Get ("date_moment_ago");

         elsif Dt < 120.0 then
            return Bundle.Get ("date_minute_ago");

         elsif Dt < ONE_HOUR then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / 60.0));
            ASF.Utils.Formats.Format (Bundle.Get ("date_minutes_ago"),
                                      Values, Result);

         elsif Dt < 2 * ONE_HOUR then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / 60.0));
            ASF.Utils.Formats.Format (Bundle.Get ("date_hour_ago"),
                                      Values, Result);

         elsif Dt < ONE_DAY then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / ONE_HOUR));
            ASF.Utils.Formats.Format (Bundle.Get ("date_hours_ago"),
                                      Values, Result);

         elsif Dt < 2 * ONE_DAY then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / ONE_HOUR));
            ASF.Utils.Formats.Format (Bundle.Get ("date_day_ago"),
                                      Values, Result);

         elsif Dt < 7 * ONE_DAY then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / ONE_DAY));
            ASF.Utils.Formats.Format (Bundle.Get ("date_days_ago"),
                                      Values, Result);

         else
            declare
               use ASF.Converters.Dates;

               Pattern : constant String
                 := Date_Converter'Class (Convert).Get_Pattern (Context, Component);
            begin
               return Util.Dates.Formats.Format (Pattern, Date, Bundle);
            end;
         end if;
         return Ada.Strings.Unbounded.To_String (Result);
      end;

   exception
      when E : others =>
         raise ASF.Converters.Invalid_Conversion with Ada.Exceptions.Exception_Message (E);

   end To_String;

end AWA.Converters.Dates;

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

with Util.Locales;
with Util.Dates.Formats;
with Util.Properties.Bundles;
with Util.Beans.Objects.Time;

with ASF.Locales;
with ASF.Utils;
with ASF.Applications.Main;
package body AWA.Converters.Dates is

   ONE_HOUR : constant Duration := 3600.0;
   ONE_DAY  : constant Duration := 24 * ONE_HOUR;

   --  ------------------------------
   --  Convert the object value into a string.  The object value is associated
   --  with the specified component.
   --  If the string cannot be converted, the Invalid_Conversion exception should be raised.
   --  ------------------------------
   overriding
   function To_String (Convert   : in Relative_Date_Converter;
                       Context   : in ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in ASF.Components.Base.UIComponent'Class;
                       Value     : in Util.Beans.Objects.Object) return String is
      Bundle  : ASF.Locales.Bundle;
      Locale  : constant Util.Locales.Locale := Context.Get_Locale;
   begin
      begin
         ASF.Applications.Main.Load_Bundle (Context.Get_Application.all,
                                            Name   => "dates",
                                            Locale => Util.Locales.To_String (Locale),
                                            Bundle => Bundle);

      exception
         when E : Util.Properties.Bundles.NO_BUNDLE =>
            Component.Log_Error ("Cannot localize dates: {0}",
                                 Ada.Exceptions.Exception_Message (E));
      end;

      --  Convert the value as a date here so that we can raise an Invalid_Conversion exception.
      declare
         use Ada.Calendar;

         Date    : constant Ada.Calendar.Time := Util.Beans.Objects.Time.To_Time (Value);
         Now     : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Dt      : constant Duration := Now - Date;
         Values  : ASF.Utils.Object_Array (1 .. 1);
         Result  : Ada.Strings.Unbounded.Unbounded_String;
      begin
         if Dt < 60.0 then
            return Bundle.Get ("date_moment_ago");

         elsif Dt < 120.0 then
            return Bundle.Get ("date_minute_ago");

         elsif Dt < ONE_HOUR then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / 60.0));
            ASF.Utils.Formats.Format (Bundle.Get ("date_minutes_ago"),
                                      Values, Result);

         elsif Dt < 2 * ONE_HOUR then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / 60.0));
            ASF.Utils.Formats.Format (Bundle.Get ("date_hour_ago"),
                                      Values, Result);

         elsif Dt < ONE_DAY then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / ONE_HOUR));
            ASF.Utils.Formats.Format (Bundle.Get ("date_hours_ago"),
                                      Values, Result);

         elsif Dt < 2 * ONE_DAY then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / ONE_HOUR));
            ASF.Utils.Formats.Format (Bundle.Get ("date_day_ago"),
                                      Values, Result);

         elsif Dt < 7 * ONE_DAY then
            Values (1) := Util.Beans.Objects.To_Object (Natural (Dt / ONE_DAY));
            ASF.Utils.Formats.Format (Bundle.Get ("date_days_ago"),
                                      Values, Result);

         else
            declare
               use ASF.Converters.Dates;

               Pattern : constant String
                 := Date_Converter'Class (Convert).Get_Pattern (Context, Bundle, Component);
            begin
               return Util.Dates.Formats.Format (Pattern, Date, Bundle);
            end;
         end if;
         return Ada.Strings.Unbounded.To_String (Result);
      end;

   exception
      when E : others =>
         raise ASF.Converters.Invalid_Conversion with Ada.Exceptions.Exception_Message (E);

   end To_String;

end AWA.Converters.Dates;

Add the bundle to the Get_Pattern function call


-- Lumen.Events.Key_Translate -- Translate X11 keysym to Lumen symbol
--
-- Chip Richards, NiEstu, Phoenix AZ, Summer 2010

-- This code is covered by the ISC License:
--
-- Copyright © 2010, NiEstu
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- The software is provided "as is" and the author disclaims all warranties
-- with regard to this software including all implied warranties of
-- merchantability and fitness. In no event shall the author be liable for any
-- special, direct, indirect, or consequential damages or any damages
-- whatsoever resulting from loss of use, data or profits, whether in an
-- action of contract, negligence or other tortious action, arising out of or
-- in connection with the use or performance of this software.

-- Environment
with Ada.Characters.Latin_1;
with Lumen.Events.Keys;        use Lumen.Events.Keys;

package body Lumen.Events.Key_Translate is

   -- Useful range boundaries and other markers
   Lo_Char        : constant Key_Symbol := Key_Symbol (Character'Pos (Character'First));
   Hi_Char        : constant Key_Symbol := Key_Symbol (Character'Pos (Character'Last));
   Lo_Graphic     : constant Key_Symbol := Key_Symbol (Character'Pos (Ada.Characters.Latin_1.Space));
   Lo_Spec_1      : constant Key_Symbol := 16#FF08#;  -- X11 backspace
   Hi_Spec_1      : constant Key_Symbol := 16#FF1B#;  -- X11 escape
   Lo_Spec_2      : constant Key_Symbol := Home;
   Hi_Spec_2      : constant Key_Symbol := KP_Equal;
   Lo_Mod         : constant Key_Symbol := Shift_L;
   Hi_Mod         : constant Key_Symbol := Hyper_R;
   Lo_Func        : constant Key_Symbol := F1;
   Hi_Func        : constant Key_Symbol := F35;
   Unknown_Symbol : constant Key_Symbol := Key_Symbol'Last;
   Self_Symbol    : constant Key_Symbol := Key_Symbol'Last - 1;

   -- Translation array for specials that turn into Latin-1 control
   -- characters, or themselves
   type Translation_Target is record
      Val : Key_Symbol;
      Cat : Key_Category;
   end record;
   type Special_1_Translation is array (Lo_Spec_1 .. Hi_Spec_1) of Translation_Target;
   Specials_1 : Special_1_Translation :=
      (
       16#FF08#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.BS)),  Key_Control),
       16#FF09#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.HT)),  Key_Control),
       16#FF0A#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.LF)),  Key_Control),
       Clear       => (Clear,                                                   Key_Special),
       16#FF0D#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.CR)),  Key_Control),
       Pause       => (Pause,                                                   Key_Special),
       Scroll_Lock => (Scroll_Lock,                                             Key_Special),
       Sys_Req     => (Sys_Req,                                                 Key_Special),
       16#FF1B#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.ESC)), Key_Control),
       others      => (Unknown_Symbol,                                          Key_Unknown)
      );

   -- Translation array for specials that turn into themselves; needed because
   -- the ranges are discontinuous and have holes
   type Special_2_Translation is array (Lo_Spec_2 .. Hi_Spec_2) of Key_Symbol;
   Specials_2 : Special_2_Translation :=
      (
       Home         => Self_Symbol,
       Left         => Self_Symbol,
       Up           => Self_Symbol,
       Right        => Self_Symbol,
       Down         => Self_Symbol,
       Page_Up      => Self_Symbol,
       Page_Down    => Self_Symbol,
       End_Key      => Self_Symbol,
       Begin_Key    => Self_Symbol,
       Select_Key   => Self_Symbol,
       Print        => Self_Symbol,
       Execute      => Self_Symbol,
       Insert       => Self_Symbol,
       Undo         => Self_Symbol,
       Redo         => Self_Symbol,
       Menu         => Self_Symbol,
       Find         => Self_Symbol,
       Cancel       => Self_Symbol,
       Help         => Self_Symbol,
       Break        => Self_Symbol,
       Mode_Switch  => Self_Symbol,
       Num_Lock     => Self_Symbol,
       KP_Space     => Self_Symbol,
       KP_Tab       => Self_Symbol,
       KP_Enter     => Self_Symbol,
       KP_F1        => Self_Symbol,
       KP_F2        => Self_Symbol,
       KP_F3        => Self_Symbol,
       KP_F4        => Self_Symbol,
       KP_Home      => Self_Symbol,
       KP_Left      => Self_Symbol,
       KP_Up        => Self_Symbol,
       KP_Right     => Self_Symbol,
       KP_Down      => Self_Symbol,
       KP_Page_Up   => Self_Symbol,
       KP_Page_Down => Self_Symbol,
       KP_End       => Self_Symbol,
       KP_Begin     => Self_Symbol,
       KP_Insert    => Self_Symbol,
       KP_Delete    => Self_Symbol,
       KP_Equal     => Self_Symbol,
       KP_Multiply  => Self_Symbol,
       KP_Add       => Self_Symbol,
       KP_Separator => Self_Symbol,
       KP_Subtract  => Self_Symbol,
       KP_Decimal   => Self_Symbol,
       KP_Divide    => Self_Symbol,
       KP_0         => Self_Symbol,
       KP_1         => Self_Symbol,
       KP_2         => Self_Symbol,
       KP_3         => Self_Symbol,
       KP_4         => Self_Symbol,
       KP_5         => Self_Symbol,
       KP_6         => Self_Symbol,
       KP_7         => Self_Symbol,
       KP_8         => Self_Symbol,
       KP_9         => Self_Symbol,
       others       => Unknown_Symbol
      );

   -- Translate an X11 keysym to a Lumen symbol and a category.  The keysym
   -- comes in as a Key_Symbol type, but it's not really one just yet
   procedure Keysym_To_Symbol (Incoming  : in     Key_Symbol;
                               Modifiers : in     Modifier_Set;
                               Outgoing  :    out Key_Symbol;
                               Category  :    out Key_Category) is
   begin  -- Keysym_To_Symbol

      -- Modifiers, like shift, ctrl, alt, etc.
      if Incoming in Lo_Mod .. Hi_Mod then
         Outgoing := Incoming;
         Category := Key_Modifier;

      -- Function keys
      elsif Incoming in Lo_Func .. Hi_Func then
         Outgoing := Incoming;
         Category := Key_Function;

      -- First group of specials; some actually get translated
      elsif Incoming in Lo_Spec_1 .. Hi_Spec_1 then
         if Specials_1 (Incoming).Val = Unknown_Symbol then
            Outgoing := Incoming;  -- just retain its X11 value, whatever it means; maybe the user will know
            Category := Key_Unknown;
         else
            Outgoing := Specials_1 (Incoming).Val;
            Category := Specials_1 (Incoming).Cat;
         end if;

      -- Second group of specials, which all retain their values
      elsif Incoming in Lo_Spec_2 .. Hi_Spec_2 then
         Outgoing := Incoming;
         if Specials_2 (Incoming) = Unknown_Symbol then
            Category := Key_Unknown;
         else
            Category := Key_Special;
         end if;

      -- Finally, deal with straight Latin-1 characters; shouldn't get here
      -- because we catch them in Events, but just in case
      elsif Incoming in Lo_Char .. Hi_Char then
         Outgoing := Incoming;
         if Incoming < Lo_Graphic or Incoming = Character'Pos (Ada.Characters.Latin_1.DEL) then
            Category := Key_Control;
         else
            Category := Key_Graphic;
         end if;

      -- Any keysym that doesn't meet the above specifications
      else
         Outgoing := Incoming;
         Category := Key_Unknown;
      end if;
   end Keysym_To_Symbol;

end Lumen.Events.Key_Translate;

-- Lumen.Events.Key_Translate -- Translate X11 keysym to Lumen symbol
--
-- Chip Richards, NiEstu, Phoenix AZ, Summer 2010

-- This code is covered by the ISC License:
--
-- Copyright © 2010, NiEstu
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- The software is provided "as is" and the author disclaims all warranties
-- with regard to this software including all implied warranties of
-- merchantability and fitness. In no event shall the author be liable for any
-- special, direct, indirect, or consequential damages or any damages
-- whatsoever resulting from loss of use, data or profits, whether in an
-- action of contract, negligence or other tortious action, arising out of or
-- in connection with the use or performance of this software.

-- Environment
with Ada.Characters.Latin_1;
with Lumen.Events.Keys;        use Lumen.Events.Keys;

package body Lumen.Events.Key_Translate is

   -- Useful range boundaries and other markers
   Lo_Char        : constant Key_Symbol := Key_Symbol (Character'Pos (Character'First));
   Hi_Char        : constant Key_Symbol := Key_Symbol (Character'Pos (Character'Last));
   Lo_Graphic     : constant Key_Symbol := Key_Symbol (Character'Pos (Ada.Characters.Latin_1.Space));
   Lo_Spec_1      : constant Key_Symbol := 16#FF08#;  -- X11 backspace
   Hi_Spec_1      : constant Key_Symbol := 16#FF1B#;  -- X11 escape
   Lo_Spec_2      : constant Key_Symbol := Home;
   Hi_Spec_2      : constant Key_Symbol := KP_Equal;
   Lo_Mod         : constant Key_Symbol := Shift_L;
   Hi_Mod         : constant Key_Symbol := Hyper_R;
   Lo_Func        : constant Key_Symbol := F1;
   Hi_Func        : constant Key_Symbol := F35;
   Unknown_Symbol : constant Key_Symbol := Key_Symbol'Last;
   Self_Symbol    : constant Key_Symbol := Key_Symbol'Last - 1;

   -- Translation array for specials that turn into Latin-1 control
   -- characters, or themselves
   type Translation_Target is record
      Val : Key_Symbol;
      Cat : Key_Category;
   end record;
   type Special_1_Translation is array (Lo_Spec_1 .. Hi_Spec_1) of Translation_Target;
   Specials_1 : Special_1_Translation :=
      (
       16#FF08#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.BS)),  Key_Control),
       16#FF09#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.HT)),  Key_Control),
       16#FF0A#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.LF)),  Key_Control),
       Clear       => (Clear,                                                   Key_Special),
       16#FF0D#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.CR)),  Key_Control),
       Pause       => (Pause,                                                   Key_Special),
       Scroll_Lock => (Scroll_Lock,                                             Key_Special),
       Sys_Req     => (Sys_Req,                                                 Key_Special),
       16#FF1B#    => (Key_Symbol (Character'Pos (Ada.Characters.Latin_1.ESC)), Key_Control),
       others      => (Unknown_Symbol,                                          Key_Unknown)
      );

   -- Translation array for specials that turn into themselves; needed because
   -- the ranges are discontinuous and have holes
   type Special_2_Translation is array (Lo_Spec_2 .. Hi_Spec_2) of Key_Symbol;
   Specials_2 : Special_2_Translation :=
      (
       Home         => Self_Symbol,
       Left         => Self_Symbol,
       Up           => Self_Symbol,
       Right        => Self_Symbol,
       Down         => Self_Symbol,
       Page_Up      => Self_Symbol,
       Page_Down    => Self_Symbol,
       End_Key      => Self_Symbol,
       Begin_Key    => Self_Symbol,
       Select_Key   => Self_Symbol,
       Print        => Self_Symbol,
       Execute      => Self_Symbol,
       Insert       => Self_Symbol,
       Undo         => Self_Symbol,
       Redo         => Self_Symbol,
       Menu         => Self_Symbol,
       Find         => Self_Symbol,
       Cancel       => Self_Symbol,
       Help         => Self_Symbol,
       Break        => Self_Symbol,
       Mode_Switch  => Self_Symbol,
       Num_Lock     => Self_Symbol,
       KP_Space     => Self_Symbol,
       KP_Tab       => Self_Symbol,
       KP_Enter     => Self_Symbol,
       KP_F1        => Self_Symbol,
       KP_F2        => Self_Symbol,
       KP_F3        => Self_Symbol,
       KP_F4        => Self_Symbol,
       KP_Home      => Self_Symbol,
       KP_Left      => Self_Symbol,
       KP_Up        => Self_Symbol,
       KP_Right     => Self_Symbol,
       KP_Down      => Self_Symbol,
       KP_Page_Up   => Self_Symbol,
       KP_Page_Down => Self_Symbol,
       KP_End       => Self_Symbol,
       KP_Begin     => Self_Symbol,
       KP_Insert    => Self_Symbol,
       KP_Delete    => Self_Symbol,
       KP_Equal     => Self_Symbol,
       KP_Multiply  => Self_Symbol,
       KP_Add       => Self_Symbol,
       KP_Separator => Self_Symbol,
       KP_Subtract  => Self_Symbol,
       KP_Decimal   => Self_Symbol,
       KP_Divide    => Self_Symbol,
       KP_0         => Self_Symbol,
       KP_1         => Self_Symbol,
       KP_2         => Self_Symbol,
       KP_3         => Self_Symbol,
       KP_4         => Self_Symbol,
       KP_5         => Self_Symbol,
       KP_6         => Self_Symbol,
       KP_7         => Self_Symbol,
       KP_8         => Self_Symbol,
       KP_9         => Self_Symbol,
       others       => Unknown_Symbol
      );

   -- Translate an X11 keysym to a Lumen symbol and a category.  The keysym
   -- comes in as a Key_Symbol type, but it's not really one just yet
   procedure Keysym_To_Symbol (Incoming  : in     Key_Symbol;
                               Modifiers : in     Modifier_Set;
                               Outgoing  :    out Key_Symbol;
                               Category  :    out Key_Category) is
   begin  -- Keysym_To_Symbol

      -- Modifiers, like shift, ctrl, alt, etc.
      case Incoming is
         when Lo_Mod .. Hi_Mod =>
            Outgoing := Incoming;
            Category := Key_Modifier;

         -- Function keys
         when Lo_Func .. Hi_Func =>
            Outgoing := Incoming;
            Category := Key_Function;

         -- First group of specials; some actually get translated
         when Lo_Spec_1 .. Hi_Spec_1 =>
            if Specials_1 (Incoming).Val = Unknown_Symbol then
               Outgoing := Incoming;  -- just retain its X11 value, whatever it means; maybe the user will know
               Category := Key_Unknown;
            else
               Outgoing := Specials_1 (Incoming).Val;
               Category := Specials_1 (Incoming).Cat;
            end if;

         -- Second group of specials, which all retain their values
         when Lo_Spec_2 .. Hi_Spec_2 =>
            Outgoing := Incoming;
            if Specials_2 (Incoming) = Unknown_Symbol then
               Category := Key_Unknown;
            else
               Category := Key_Special;
            end if;

         -- Finally, deal with straight Latin-1 characters; shouldn't get here
         -- because we catch them in Events, but just in case
         when Lo_Char .. Hi_Char =>
            Outgoing := Incoming;
            if Incoming < Lo_Graphic or Incoming = Character'Pos (Ada.Characters.Latin_1.DEL) then
               Category := Key_Control;
            else
               Category := Key_Graphic;
            end if;

         -- Any keysym that doesn't meet the above specifications
         when others =>
            Outgoing := Incoming;
            Category := Key_Unknown;
      end case;
   end Keysym_To_Symbol;

end Lumen.Events.Key_Translate;

Events: Replace series of if statements with case.

Signed-off-by: darkestkhan <e9a7a7cf2a6af79e93742343a7a5cac5d90f9bd2@gmail.com>


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

   use type Maps.Map_Bean_Access;
   use type Vectors.Vector_Bean_Access;

   --  Start a document.
   overriding
   procedure Start_Document (Handler : in out Reader) is
   begin
      Object_Stack.Clear (Handler.Context);
      Object_Stack.Push (Handler.Context);
      Object_Stack.Current (Handler.Context).Map := new Maps.Map_Bean;
   end Start_Document;

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String) is
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.Map := new Maps.Map_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String) is
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Reader;
                          Name    : in String) is
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.List := new Vectors.Vector_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural) is
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False) is
      pragma Unreferenced (Attribute);
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
   begin
      if Current.Map /= null then
         Current.Map.Set_Value (Name, Value);
      else
         Current.List.Append (Value);
      end if;
   end Set_Member;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Reader;
                    Message : in String) is
   begin
      null;
   end Error;

end Util.Beans.Objects.Readers;

-----------------------------------------------------------------------
--  util-beans-objects-readers -- Datasets
--  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 Util.Serialize.IO;
package body Util.Beans.Objects.Readers is

   use type Maps.Map_Bean_Access;
   use type Vectors.Vector_Bean_Access;

   --  Start a document.
   overriding
   procedure Start_Document (Handler : in out Reader) is
   begin
      Object_Stack.Clear (Handler.Context);
      Object_Stack.Push (Handler.Context);
      Object_Stack.Current (Handler.Context).Map := new Maps.Map_Bean;
   end Start_Document;

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  <b>Set_Member</b> procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.Map := new Maps.Map_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
      Next    : Object_Context_Access;
   begin
      Object_Stack.Push (Handler.Context);
      Next := Object_Stack.Current (Handler.Context);
      Next.List := new Vectors.Vector_Bean;
      if Current.Map /= null then
         Current.Map.Include (Name, To_Object (Next.List, DYNAMIC));
      else
         Current.List.Append (To_Object (Next.List, DYNAMIC));
      end if;
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is
   begin
      Object_Stack.Pop (Handler.Context);
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   overriding
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is
      pragma Unreferenced (Attribute);
      Current : constant Object_Context_Access := Object_Stack.Current (Handler.Context);
   begin
      if Current.Map /= null then
         Current.Map.Set_Value (Name, Value);
      else
         Current.List.Append (Value);
      end if;
   end Set_Member;

end Util.Beans.Objects.Readers;

Add a Logger parameter to the Reader operations Remove the Error procedure


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with File_Operations;
with PortScan.Log;
with Parameters;
with Unix;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;

package body PortScan.Tests is

   package FOP renames File_Operations;
   package LOG renames PortScan.Log;
   package PM  renames Parameters;
   package LAT renames Ada.Characters.Latin_1;
   package DIR renames Ada.Directories;
   package EX  renames Ada.Exceptions;

   --------------------------------------------------------------------------------------------
   --  exec_phase_check_plist
   --------------------------------------------------------------------------------------------
   function exec_check_plist
     (specification : PSP.Portspecs;
      log_handle    : TIO.File_Type;
      phase_name    : String;
      seq_id        : port_id;
      port_prefix   : String;
      rootdir       : String) return Boolean
   is
      passed_check : Boolean := True;
      namebase     : constant String := specification.get_namebase;
      directory_list : entry_crate.Map;
      dossier_list   : entry_crate.Map;
   begin
      LOG.log_phase_begin (log_handle, phase_name);
      TIO.Put_Line (log_handle, "====> Checking for package manifest issues");

      if not ingest_manifests (specification  => specification,
                               log_handle     => log_handle,
                               directory_list => directory_list,
                               dossier_list   => dossier_list,
                               seq_id         => seq_id,
                               namebase       => namebase,
                               port_prefix    => port_prefix,
                               rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if orphaned_directories_detected (log_handle     => log_handle,
                                        directory_list => directory_list,
                                        namebase       => namebase,
                                        port_prefix    => port_prefix,
                                        rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if missing_directories_detected (log_handle, directory_list) then
         passed_check := False;
      end if;

      if orphaned_files_detected (log_handle   => log_handle,
                                  dossier_list => dossier_list,
                                  namebase     => namebase,
                                  port_prefix  => port_prefix,
                                  rootdir      => rootdir)
      then
         passed_check := False;
      end if;

      if missing_files_detected (log_handle, dossier_list) then
         passed_check := False;
      end if;

      if passed_check then
         TIO.Put_Line (log_handle, "====> No manifest issues found");
      end if;

      LOG.log_phase_end (log_handle);
      return passed_check;
   end exec_check_plist;

   --------------------------------------------------------------------------------------------
   --  ingest_manifests
   --------------------------------------------------------------------------------------------
   function ingest_manifests
     (specification  : PSP.Portspecs;
      log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      dossier_list   : in out entry_crate.Map;
      seq_id         : port_id;
      namebase       : String;
      port_prefix    : String;
      rootdir        : String) return Boolean
   is
      procedure eat_plist (position : subpackage_crate.Cursor);
      procedure insert_directory (directory : String; subpackage : HT.Text);

      result   : Boolean := True;

      procedure insert_directory (directory : String; subpackage : HT.Text)
      is
         numsep : Natural := HT.count_char (directory, LAT.Solidus);
         canvas : HT.Text := HT.SUS (directory);
      begin
         for x in 1 .. numsep + 1 loop
            declare
               paint      : String := HT.USS (canvas);
               my_new_rec : entry_record := (subpackage, False);
            begin
               if paint /= "" then
                  if not directory_list.Contains (canvas) then
                     directory_list.Insert (canvas, my_new_rec);
                  end if;
                  canvas := HT.SUS (HT.head (paint, "/"));
               end if;
            end;
         end loop;
      end insert_directory;

      procedure eat_plist (position : subpackage_crate.Cursor)
      is
         subpackage    : HT.Text := subpackage_crate.Element (position).subpackage;
         manifest_file : String := "/construction/" & namebase & "/.manifest." &
                         HT.USS (subpackage) & ".mktmp";
         contents      : String := FOP.get_file_contents (rootdir & manifest_file);
         identifier    : constant String := HT.USS (subpackage) & " manifest: ";
         markers       : HT.Line_Markers;
      begin
         HT.initialize_markers (contents, markers);
         loop
            exit when not HT.next_line_present (contents, markers);
            declare
               line      : constant String := HT.extract_line (contents, markers);
               line_text : HT.Text := HT.SUS (line);
               new_rec   : entry_record := (subpackage, False);
            begin
               if HT.leads (line, "@comment ") or else
                 HT.leads (line, "@terminfo") or else
                 HT.leads (line, "@rmtry ") or else
                 HT.leads (line, "@postexec ")
               then
                  null;
               elsif HT.leads (line, "@dir ") then
                  declare
                     dir : String :=
                           convert_to_absolute_path (port_prefix, HT.substring (line, 5, 0));
                     dir_text  : HT.Text := HT.SUS (dir);
                     excludeit : Boolean;
                  begin
                     if directory_list.Contains (dir_text) then
                        --  There is one case where a redundant @dir symbol is desired:
                        --  *) when a non-standard PREFIX is used.  Pkg(8) needs to be given an
                        --     explicit command to remove the package's root directory.
                        excludeit := (LAT.Solidus & dir = port_prefix) and then
                          (port_prefix /= HT.USS (PM.configuration.dir_localbase));

                        if not excludeit then
                           result := False;
                           declare
                              spkg : String :=
                                HT.USS (directory_list.Element (dir_text).subpackage);
                           begin
                              if spkg /= "" then
                                 TIO.Put_Line
                                   (log_handle,
                                    "Redundant @dir symbol, " & identifier & dir &
                                      " will already be created by the " & spkg & " manifest");
                              else
                                 TIO.Put_Line
                                   (log_handle,
                                    "Redundant @dir symbol, " & identifier & dir &
                                      " will already be created by another manifest");
                              end if;
                           end;
                        end if;
                     else
                        insert_directory (dir, subpackage);
                     end if;
                  end;
               else
                  declare
                     modline : String  := modify_file_if_necessary (port_prefix, line);
                     ml_text : HT.Text := HT.SUS (modline);
                  begin
                     if dossier_list.Contains (ml_text) then
                        result := False;
                        declare
                           spkg : String := HT.USS (dossier_list.Element (ml_text).subpackage);
                        begin
                           TIO.Put_Line
                             (log_handle,
                              "Duplicate file entry, " & identifier & modline &
                                " already present in " & spkg & " manifest");
                        end;
                     else
                        dossier_list.Insert (ml_text, new_rec);
                        declare
                           plistdir : String := DIR.Containing_Directory (modline);
                        begin
                           insert_directory (plistdir, subpackage);
                        end;
                     end if;
                  end;
               end if;
            end;
         end loop;
      exception
         when issue : others =>
            TIO.Put_Line (log_handle, "check-plist error: " & EX.Exception_Message (issue));
      end eat_plist;
   begin
      all_ports (seq_id).subpackages.Iterate (eat_plist'Access);
      return result;
   end ingest_manifests;

   --------------------------------------------------------------------------------------------
   --  directory_excluded
   --------------------------------------------------------------------------------------------
   function directory_excluded (port_prefix, candidate : String) return Boolean
   is
      --  mandatory candidate has ${STAGEDIR}/ stripped (no leading slash)
      localbase : constant String  := HT.substring (port_prefix, 1, 0);
      lblen     : constant Natural := localbase'Length;
   begin
      if candidate = localbase then
         return True;
      end if;

      declare
         shortcan : String := HT.substring (candidate, lblen + 1, 0);
      begin
         if shortcan = "bin" or else
           shortcan = "etc" or else
           shortcan = "etc/rc.d" or else
           shortcan = "include" or else
           shortcan = "lib" or else
           shortcan = "lib/pkgconfig" or else
           shortcan = "libdata" or else
           shortcan = "libexec" or else
           shortcan = "sbin" or else
           shortcan = "share" or else
           shortcan = "www"
         then
            return True;
         end if;
         if not HT.leads (shortcan, "share/") then
            return False;
         end if;
      end;

      declare
         shortcan : String := HT.substring (candidate, lblen + 7, 0);
      begin
         if shortcan = "doc" or else
           shortcan = "examples" or else
           shortcan = "info" or else
           shortcan = "locale" or else
           shortcan = "man" or else
           shortcan = "nls"
         then
            return True;
         end if;
         if shortcan'Length /= 8 or else
           not HT.leads (shortcan, "man/man")
         then
            return False;
         end if;
         case shortcan (shortcan'Last) is
            when '1' .. '9' | 'l' | 'n' => return True;
            when others => return False;
         end case;
      end;
   end directory_excluded;

   --------------------------------------------------------------------------------------------
   --  orphaned_directories_detected
   --------------------------------------------------------------------------------------------
   function orphaned_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      namebase       : String;
      port_prefix    : String;
      rootdir        : String) return Boolean
   is
      localbase : constant String  := HT.substring (port_prefix, 1, 0);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir & " -type d -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned directory detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_directories_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line      : constant String := HT.extract_line (comres, markers);
            plist_dir : HT.Text := HT.SUS (line);
         begin
            if line /= "" then
               if directory_list.Contains (plist_dir) then
                  directory_list.Update_Element (Position => directory_list.Find (plist_dir),
                                                 Process  => mark_verified'Access);
               else
                  if not directory_excluded (port_prefix, line) then
                     if HT.leads (line, localbase) then
                        TIO.Put_Line (log_handle, errprefix & HT.substring (line, lblen + 1, 0));
                     else
                        TIO.Put_Line (log_handle, errprefix & line);
                     end if;
                     result := True;
                  end if;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_directories_detected;

   --------------------------------------------------------------------------------------------
   --  mark_verified
   --------------------------------------------------------------------------------------------
   procedure mark_verified (key : HT.Text; Element : in out entry_record) is
   begin
      Element.verified := True;
   end mark_verified;

   --------------------------------------------------------------------------------------------
   --  missing_directories_detected
   --------------------------------------------------------------------------------------------
   function missing_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec       : entry_record renames entry_crate.Element (position);
         plist_dir : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "Directory " & plist_dir & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      directory_list.Iterate (check'Access);
      return result;
   end missing_directories_detected;

   --------------------------------------------------------------------------------------------
   --  missing_files_detected
   --------------------------------------------------------------------------------------------
   function missing_files_detected
     (log_handle   : TIO.File_Type;
      dossier_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec        : entry_record renames entry_crate.Element (position);
         plist_file : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "File " & plist_file & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      dossier_list.Iterate (check'Access);
      return result;
   end missing_files_detected;

   --------------------------------------------------------------------------------------------
   --  orphaned_files_detected
   --------------------------------------------------------------------------------------------
   function orphaned_files_detected
     (log_handle     : TIO.File_Type;
      dossier_list   : in out entry_crate.Map;
      namebase       : String;
      port_prefix    : String;
      rootdir        : String) return Boolean
   is
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := HT.substring (rawlbase, 1, 0);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir &
                  " \( -type f -o -type l \) -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned file detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_files_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line       : constant String := HT.extract_line (comres, markers);
            plist_file : HT.Text := HT.SUS (line);
         begin
            if not HT.IsBlank (plist_file) then
               if dossier_list.Contains (plist_file) then
                  dossier_list.Update_Element (Position => dossier_list.Find (plist_file),
                                               Process  => mark_verified'Access);
               else
                  TIO.Put_Line (log_handle, errprefix & line);
                  result := True;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_files_detected;

   --------------------------------------------------------------------------------------------
   --  modify_file_if_necessary
   --------------------------------------------------------------------------------------------
   function modify_file_if_necessary (port_prefix, original : String) return String is
   begin
      if HT.leads (original, "@info ") then
         return convert_to_absolute_path (port_prefix, HT.substring (original, 6, 0));
      elsif HT.leads (original, "@sample ") then
         return convert_to_absolute_path (port_prefix, HT.substring (original, 8, 0));
      else
         return convert_to_absolute_path (port_prefix, original);
      end if;
   end modify_file_if_necessary;

   --------------------------------------------------------------------------------------------
   --  convert_to_absolute_path
   --------------------------------------------------------------------------------------------
   function convert_to_absolute_path (port_prefix, raw : String) return String is
   begin
      if raw'Length < 2 then
         return raw;
      end if;
      if raw (raw'First) = LAT.Solidus then
         return HT.substring (raw, 1, 0);
      end if;
      return HT.substring (port_prefix, 1, 0) & LAT.Solidus & raw;
   end convert_to_absolute_path;

end PortScan.Tests;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with File_Operations;
with PortScan.Log;
with Parameters;
with Unix;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;

package body PortScan.Tests is

   package FOP renames File_Operations;
   package LOG renames PortScan.Log;
   package PM  renames Parameters;
   package LAT renames Ada.Characters.Latin_1;
   package DIR renames Ada.Directories;
   package EX  renames Ada.Exceptions;

   --------------------------------------------------------------------------------------------
   --  exec_phase_check_plist
   --------------------------------------------------------------------------------------------
   function exec_check_plist
     (specification : PSP.Portspecs;
      log_handle    : TIO.File_Type;
      phase_name    : String;
      seq_id        : port_id;
      port_prefix   : String;
      rootdir       : String) return Boolean
   is
      passed_check : Boolean := True;
      namebase     : constant String := specification.get_namebase;
      directory_list : entry_crate.Map;
      dossier_list   : entry_crate.Map;
   begin
      LOG.log_phase_begin (log_handle, phase_name);
      TIO.Put_Line (log_handle, "====> Checking for package manifest issues");

      if not ingest_manifests (specification  => specification,
                               log_handle     => log_handle,
                               directory_list => directory_list,
                               dossier_list   => dossier_list,
                               seq_id         => seq_id,
                               namebase       => namebase,
                               port_prefix    => port_prefix,
                               rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if orphaned_directories_detected (log_handle     => log_handle,
                                        directory_list => directory_list,
                                        namebase       => namebase,
                                        port_prefix    => port_prefix,
                                        rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if missing_directories_detected (log_handle, directory_list) then
         passed_check := False;
      end if;

      if orphaned_files_detected (log_handle   => log_handle,
                                  dossier_list => dossier_list,
                                  namebase     => namebase,
                                  port_prefix  => port_prefix,
                                  rootdir      => rootdir)
      then
         passed_check := False;
      end if;

      if missing_files_detected (log_handle, dossier_list) then
         passed_check := False;
      end if;

      if passed_check then
         TIO.Put_Line (log_handle, "====> No manifest issues found");
      end if;

      LOG.log_phase_end (log_handle);
      return passed_check;
   end exec_check_plist;

   --------------------------------------------------------------------------------------------
   --  ingest_manifests
   --------------------------------------------------------------------------------------------
   function ingest_manifests
     (specification  : PSP.Portspecs;
      log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      dossier_list   : in out entry_crate.Map;
      seq_id         : port_id;
      namebase       : String;
      port_prefix    : String;
      rootdir        : String) return Boolean
   is
      procedure eat_plist (position : subpackage_crate.Cursor);
      procedure insert_directory (directory : String; subpackage : HT.Text);

      result   : Boolean := True;

      procedure insert_directory (directory : String; subpackage : HT.Text)
      is
         numsep : Natural := HT.count_char (directory, LAT.Solidus);
         canvas : HT.Text := HT.SUS (directory);
      begin
         for x in 1 .. numsep + 1 loop
            declare
               paint      : String := HT.USS (canvas);
               my_new_rec : entry_record := (subpackage, False);
            begin
               if paint /= "" then
                  if not directory_list.Contains (canvas) then
                     directory_list.Insert (canvas, my_new_rec);
                  end if;
                  canvas := HT.SUS (HT.head (paint, "/"));
               end if;
            end;
         end loop;
      end insert_directory;

      procedure eat_plist (position : subpackage_crate.Cursor)
      is
         subpackage    : HT.Text := subpackage_crate.Element (position).subpackage;
         manifest_file : String := "/construction/" & namebase & "/.manifest." &
                         HT.USS (subpackage) & ".mktmp";
         contents      : String := FOP.get_file_contents (rootdir & manifest_file);
         identifier    : constant String := HT.USS (subpackage) & " manifest: ";
         markers       : HT.Line_Markers;
      begin
         HT.initialize_markers (contents, markers);
         loop
            exit when not HT.next_line_present (contents, markers);
            declare
               line      : constant String := HT.extract_line (contents, markers);
               line_text : HT.Text := HT.SUS (line);
               new_rec   : entry_record := (subpackage, False);
            begin
               if HT.leads (line, "@comment ") or else
                 HT.leads (line, "@terminfo") or else
                 HT.leads (line, "@rmtry ") or else
                 HT.leads (line, "@postexec ")
               then
                  null;
               elsif HT.leads (line, "@dir ") then
                  declare
                     dir : String :=
                           convert_to_absolute_path (port_prefix, HT.substring (line, 5, 0));
                     dir_text  : HT.Text := HT.SUS (dir);
                     excludeit : Boolean;
                  begin
                     if directory_list.Contains (dir_text) then
                        --  There is one case where a redundant @dir symbol is desired:
                        --  *) when a non-standard PREFIX is used.  Pkg(8) needs to be given an
                        --     explicit command to remove the package's root directory.
                        excludeit := (LAT.Solidus & dir = port_prefix) and then
                          (port_prefix /= HT.USS (PM.configuration.dir_localbase));

                        if not excludeit then
                           result := False;
                           declare
                              spkg : String :=
                                HT.USS (directory_list.Element (dir_text).subpackage);
                           begin
                              if spkg /= "" then
                                 TIO.Put_Line
                                   (log_handle,
                                    "Redundant @dir symbol, " & identifier & dir &
                                      " will already be created by the " & spkg & " manifest");
                              else
                                 TIO.Put_Line
                                   (log_handle,
                                    "Redundant @dir symbol, " & identifier & dir &
                                      " will already be created by another manifest");
                              end if;
                           end;
                        end if;
                     else
                        insert_directory (dir, subpackage);
                     end if;
                  end;
               else
                  declare
                     modline : String  := modify_file_if_necessary (port_prefix, line);
                     ml_text : HT.Text := HT.SUS (modline);
                  begin
                     if dossier_list.Contains (ml_text) then
                        result := False;
                        declare
                           spkg : String := HT.USS (dossier_list.Element (ml_text).subpackage);
                        begin
                           TIO.Put_Line
                             (log_handle,
                              "Duplicate file entry, " & identifier & modline &
                                " already present in " & spkg & " manifest");
                        end;
                     else
                        dossier_list.Insert (ml_text, new_rec);
                        declare
                           plistdir : String := DIR.Containing_Directory (modline);
                        begin
                           insert_directory (plistdir, subpackage);
                        end;
                     end if;
                  end;
               end if;
            end;
         end loop;
      exception
         when issue : others =>
            TIO.Put_Line (log_handle, "check-plist error: " & EX.Exception_Message (issue));
      end eat_plist;
   begin
      all_ports (seq_id).subpackages.Iterate (eat_plist'Access);
      return result;
   end ingest_manifests;

   --------------------------------------------------------------------------------------------
   --  directory_excluded
   --------------------------------------------------------------------------------------------
   function directory_excluded (port_prefix, candidate : String) return Boolean
   is
      --  mandatory candidate has ${STAGEDIR}/ stripped (no leading slash)
      localbase : constant String  := HT.substring (port_prefix, 1, 0);
      lblen     : constant Natural := localbase'Length;
   begin
      if candidate = localbase then
         return True;
      end if;

      declare
         shortcan : String := HT.substring (candidate, lblen + 1, 0);
      begin
         if shortcan = "bin" or else
           shortcan = "etc" or else
           shortcan = "etc/rc.d" or else
           shortcan = "include" or else
           shortcan = "lib" or else
           shortcan = "lib/pkgconfig" or else
           shortcan = "libdata" or else
           shortcan = "libexec" or else
           shortcan = "sbin" or else
           shortcan = "share" or else
           shortcan = "www"
         then
            return True;
         end if;
         if not HT.leads (shortcan, "share/") then
            return False;
         end if;
      end;

      declare
         shortcan : String := HT.substring (candidate, lblen + 7, 0);
      begin
         if shortcan = "doc" or else
           shortcan = "examples" or else
           shortcan = "info" or else
           shortcan = "locale" or else
           shortcan = "man" or else
           shortcan = "nls"
         then
            return True;
         end if;
         if shortcan'Length /= 8 or else
           not HT.leads (shortcan, "man/man")
         then
            return False;
         end if;
         case shortcan (shortcan'Last) is
            when '1' .. '9' | 'l' | 'n' => return True;
            when others => return False;
         end case;
      end;
   end directory_excluded;

   --------------------------------------------------------------------------------------------
   --  orphaned_directories_detected
   --------------------------------------------------------------------------------------------
   function orphaned_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      namebase       : String;
      port_prefix    : String;
      rootdir        : String) return Boolean
   is
      localbase : constant String  := HT.substring (port_prefix, 1, 0);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir & " -type d -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned directory detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_directories_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line      : constant String := HT.extract_line (comres, markers);
            plist_dir : HT.Text := HT.SUS (line);
         begin
            if line /= "" then
               if directory_list.Contains (plist_dir) then
                  directory_list.Update_Element (Position => directory_list.Find (plist_dir),
                                                 Process  => mark_verified'Access);
               else
                  if not directory_excluded (port_prefix, line) then
                     if HT.leads (line, localbase) then
                        TIO.Put_Line (log_handle, errprefix & HT.substring (line, lblen + 1, 0));
                     else
                        TIO.Put_Line (log_handle, errprefix & line);
                     end if;
                     result := True;
                  end if;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_directories_detected;

   --------------------------------------------------------------------------------------------
   --  mark_verified
   --------------------------------------------------------------------------------------------
   procedure mark_verified (key : HT.Text; Element : in out entry_record) is
   begin
      Element.verified := True;
   end mark_verified;

   --------------------------------------------------------------------------------------------
   --  missing_directories_detected
   --------------------------------------------------------------------------------------------
   function missing_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec       : entry_record renames entry_crate.Element (position);
         plist_dir : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "Directory " & plist_dir & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      directory_list.Iterate (check'Access);
      return result;
   end missing_directories_detected;

   --------------------------------------------------------------------------------------------
   --  missing_files_detected
   --------------------------------------------------------------------------------------------
   function missing_files_detected
     (log_handle   : TIO.File_Type;
      dossier_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec        : entry_record renames entry_crate.Element (position);
         plist_file : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "File " & plist_file & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      dossier_list.Iterate (check'Access);
      return result;
   end missing_files_detected;

   --------------------------------------------------------------------------------------------
   --  orphaned_files_detected
   --------------------------------------------------------------------------------------------
   function orphaned_files_detected
     (log_handle     : TIO.File_Type;
      dossier_list   : in out entry_crate.Map;
      namebase       : String;
      port_prefix    : String;
      rootdir        : String) return Boolean
   is
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := HT.substring (rawlbase, 1, 0);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir &
                  " \( -type f -o -type l \) -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned file detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_files_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line       : constant String := HT.extract_line (comres, markers);
            plist_file : HT.Text := HT.SUS (line);
         begin
            if not HT.IsBlank (plist_file) then
               if dossier_list.Contains (plist_file) then
                  dossier_list.Update_Element (Position => dossier_list.Find (plist_file),
                                               Process  => mark_verified'Access);
               else
                  if HT.leads (line, localbase) then
                     TIO.Put_Line (log_handle, errprefix & HT.substring (line, lblen + 1, 0));
                  else
                     TIO.Put_Line (log_handle, errprefix & line);
                  end if;
                  result := True;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_files_detected;

   --------------------------------------------------------------------------------------------
   --  modify_file_if_necessary
   --------------------------------------------------------------------------------------------
   function modify_file_if_necessary (port_prefix, original : String) return String is
   begin
      if HT.leads (original, "@info ") then
         return convert_to_absolute_path (port_prefix, HT.substring (original, 6, 0));
      elsif HT.leads (original, "@sample ") then
         return convert_to_absolute_path (port_prefix, HT.substring (original, 8, 0));
      else
         return convert_to_absolute_path (port_prefix, original);
      end if;
   end modify_file_if_necessary;

   --------------------------------------------------------------------------------------------
   --  convert_to_absolute_path
   --------------------------------------------------------------------------------------------
   function convert_to_absolute_path (port_prefix, raw : String) return String is
   begin
      if raw'Length < 2 then
         return raw;
      end if;
      if raw (raw'First) = LAT.Solidus then
         return HT.substring (raw, 1, 0);
      end if;
      return HT.substring (port_prefix, 1, 0) & LAT.Solidus & raw;
   end convert_to_absolute_path;

end PortScan.Tests;

Make orphaned file message match orphaned directory message


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

with MAT.Events.Targets;
package MAT.Events.Timelines is

   --  Describe a section of the timeline.  The section has a starting and ending
   --  event that marks the boundary of the section within the collected events.
   --  The timeline section gives the duration and some statistics about memory
   --  allocation made in the section.
   type Timeline_Info is record
      Start_Id       : MAT.Events.Targets.Event_Id_Type := 0;
      Start_Time     : MAT.Types.Target_Tick_Ref := 0;
      End_Id         : MAT.Events.Targets.Event_Id_Type := 0;
      End_Time       : MAT.Types.Target_Tick_Ref := 0;
      Duration       : MAT.Types.Target_Time := 0;
      Malloc_Count   : Natural := 0;
      Realloc_Count  : Natural := 0;
      Free_Count     : Natural := 0;
   end record;

   package Timeline_Info_Vectors is
     new Ada.Containers.Vectors (Positive, Timeline_Info);

   subtype Timeline_Info_Vector is Timeline_Info_Vectors.Vector;
   subtype Timeline_Info_Cursor is Timeline_Info_Vectors.Cursor;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector);

   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector);

end MAT.Events.Timelines;

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

with MAT.Expressions;
with MAT.Events.Targets;
package MAT.Events.Timelines is

   --  Describe a section of the timeline.  The section has a starting and ending
   --  event that marks the boundary of the section within the collected events.
   --  The timeline section gives the duration and some statistics about memory
   --  allocation made in the section.
   type Timeline_Info is record
      Start_Id       : MAT.Events.Targets.Event_Id_Type := 0;
      Start_Time     : MAT.Types.Target_Tick_Ref := 0;
      End_Id         : MAT.Events.Targets.Event_Id_Type := 0;
      End_Time       : MAT.Types.Target_Tick_Ref := 0;
      Duration       : MAT.Types.Target_Time := 0;
      Malloc_Count   : Natural := 0;
      Realloc_Count  : Natural := 0;
      Free_Count     : Natural := 0;
   end record;

   package Timeline_Info_Vectors is
     new Ada.Containers.Vectors (Positive, Timeline_Info);

   subtype Timeline_Info_Vector is Timeline_Info_Vectors.Vector;
   subtype Timeline_Info_Cursor is Timeline_Info_Vectors.Cursor;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector);

   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector);

   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Targets.Size_Event_Info_Map);

end MAT.Events.Timelines;

Declare the Find_Sizes operation to gather the sizes of malloc/realloc events


------------------------------------------------------------------------------
-- Copyright (c) 2017, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Comment_Cookies provides an object to store persitent        --
-- information for comment forms.                                           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Lockable;

private with Natools.Constant_Indefinite_Ordered_Maps;

package Natools.Web.Comment_Cookies is
   pragma Preelaborate;

   Cookie_Name : constant String := "c_info";

   type Comment_Info is private;

   Null_Info : constant Comment_Info;

   function Create
     (Name : in S_Expressions.Atom_Refs.Immutable_Reference;
      Mail : in S_Expressions.Atom_Refs.Immutable_Reference;
      Link : in S_Expressions.Atom_Refs.Immutable_Reference;
      Filter : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Comment_Info;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Comment_Info;

   function Name (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Mail (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Link (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Filter (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Named_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom;

   function Positional_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom;

   type Serialization_Kind is (Named, Positional);

   type Encoder is access function (Data : in S_Expressions.Atom)
     return String;
   type Decoder is access function (Data : in String)
     return S_Expressions.Atom;

   type Codec_DB is private;

   procedure Register
     (DB : in out Codec_DB;
      Key : in Character;
      Filter : in not null Decoder);

   procedure Set_Encoder
     (DB : in out Codec_DB;
      Filter : in not null Encoder;
      Serialization : in Serialization_Kind);

   function Encode
     (DB : in Codec_DB;
      Info : in Comment_Info)
     return String;

   function Decode
     (DB : in Codec_DB;
      Cookie : in String)
     return Comment_Info;

private

   type Atom_Kind is (Name, Mail, Link, Filter);

   type Ref_Array is array (Atom_Kind)
     of S_Expressions.Atom_Refs.Immutable_Reference;

   type Comment_Info is record
      Refs : Ref_Array;
   end record;

   package Decoder_Maps is new Constant_Indefinite_Ordered_Maps
     (Character, Decoder);

   type Codec_DB is record
      Enc : Encoder := null;
      Dec : Decoder_Maps.Constant_Map;
      Serialization : Serialization_Kind := Named;
   end record;

   function Name (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Name));

   function Mail (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Mail));

   function Link (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Link));

   function Filter (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Filter));

   Null_Info : constant Comment_Info
     := (Refs => (others => S_Expressions.Atom_Refs.Null_Immutable_Reference));

end Natools.Web.Comment_Cookies;

------------------------------------------------------------------------------
-- Copyright (c) 2017, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Comment_Cookies provides an object to store persitent        --
-- information for comment forms.                                           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Lockable;

private with Natools.Constant_Indefinite_Ordered_Maps;

package Natools.Web.Comment_Cookies is
   pragma Preelaborate;

   Cookie_Name : constant String := "c_info";

   type Comment_Info is private;

   Null_Info : constant Comment_Info;

   function Create
     (Name : in S_Expressions.Atom_Refs.Immutable_Reference;
      Mail : in S_Expressions.Atom_Refs.Immutable_Reference;
      Link : in S_Expressions.Atom_Refs.Immutable_Reference;
      Filter : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Comment_Info;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Comment_Info;

   function Name (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Mail (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Link (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Filter (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference;

   function Named_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom;

   function Positional_Serialization (Info : in Comment_Info)
     return S_Expressions.Atom;

   type Serialization_Kind is (Named, Positional);

   type Encoder is access function (Data : in S_Expressions.Atom)
     return String;
   type Decoder is access function (Data : in String)
     return S_Expressions.Atom;

   type Codec_DB is private;

   procedure Register
     (DB : in out Codec_DB;
      Key : in Character;
      Filter : in not null Decoder);

   procedure Set_Encoder
     (DB : in out Codec_DB;
      Filter : in not null Encoder;
      Serialization : in Serialization_Kind);

   function Encode
     (DB : in Codec_DB;
      Info : in Comment_Info)
     return String;

   function Decode
     (DB : in Codec_DB;
      Cookie : in String)
     return Comment_Info;

private

   type Atom_Kind is (Filter, Name, Mail, Link);

   type Ref_Array is array (Atom_Kind)
     of S_Expressions.Atom_Refs.Immutable_Reference;

   type Comment_Info is record
      Refs : Ref_Array;
   end record;

   package Decoder_Maps is new Constant_Indefinite_Ordered_Maps
     (Character, Decoder);

   type Codec_DB is record
      Enc : Encoder := null;
      Dec : Decoder_Maps.Constant_Map;
      Serialization : Serialization_Kind := Named;
   end record;

   function Name (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Name));

   function Mail (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Mail));

   function Link (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Link));

   function Filter (Info : in Comment_Info)
     return S_Expressions.Atom_Refs.Immutable_Reference
     is (Info.Refs (Filter));

   Null_Info : constant Comment_Info
     := (Refs => (others => S_Expressions.Atom_Refs.Null_Immutable_Reference));

end Natools.Web.Comment_Cookies;

improve storage order of atoms

comment_cookies: improve storage order of atoms


--  The MIT License (MIT)

--  Copyright (c) 2015 Pavel Zhukov <landgraf@fedoraproject.org>

--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"), to deal
--  in the Software without restriction, including without limitation the rights
--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--  copies of the Software, and to permit persons to whom the Software is
--  furnished to do so, subject to the following conditions:

--  The above copyright notice and this permission notice shall be included in all
--  copies or substantial portions of the Software.

--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
--  SOFTWARE.

with Ada.Calendar;
with Ada.Text_Io;
with Nanomsg.Domains;
with Nanomsg.Pipeline;
with Aunit.Assertions;
with Nanomsg.Messages;
package body Nanomsg.Test_Message_Send_Receive_Million is

   procedure Run_Test (T : in out TC) is
      use Aunit.Assertions;
      Address : constant String := "tcp://127.0.0.1:5555";
      Msg1 : Nanomsg.Messages.Message_T;
      Msg2 : Nanomsg.Messages.Message_T := Nanomsg.Messages.Empty_Message;
      Begun : Ada.Calendar.Time;
      use type Ada.Calendar.Time;
      Dur : Duration;

   begin
      Nanomsg.Messages.From_String (Msg1, "Hello world");
      Nanomsg.Socket.Init (T.Socket1, Nanomsg.Domains.Af_Sp, Nanomsg.Pipeline.Nn_Push);
      Nanomsg.Socket.Init (T.Socket2, Nanomsg.Domains.Af_Sp, Nanomsg.Pipeline.Nn_Pull);
      Assert (Condition => not T.Socket1.Is_Null, Message => "Failed to initialize socket1");
      Assert (Condition => not T.Socket2.Is_Null, Message => "Failed to initialize socket2");
      Assert (Condition => T.Socket1.Get_Fd /= T.Socket2.Get_Fd,
              Message => "Descriptors collision!");
      Nanomsg.Socket.Connect (T.Socket1, Address);
      Nanomsg.Socket.Bind (T.Socket2, "tcp://*:5555");
      Begun := Ada.Calendar.Clock;
      for X in 1 .. 1_000_000 loop
         T.Socket1.Send (Msg1);
         T.Socket2.Receive (Msg2);
      end loop;
      Dur := Ada.Calendar.Clock - Begun;
      Ada.Text_Io.Put_Line ("Sending of million messages in pipeline mode took: " & Duration'Image (Dur) & " seconds");
      Assert (Condition => Msg1.Text = Msg2.Text,
              Message => "Message transfer failed. Texts are not identical" & Ascii.Lf &
                "Sent: " & Msg1.Text & "; Received: " & Msg2.Text);
   end Run_Test;

   function Name (T : TC) return Message_String is
   begin
      return Aunit.Format ("Test case name : Message send/receive million messages");
   end Name;

   procedure Tear_Down (T : in out Tc) is
   begin
      if T.Socket1.Get_Fd >= 0 then
         T.Socket1.Close;
      end if;
      if T.Socket2.Get_Fd >= 0 then
         T.Socket2.Close;
      end if;
   end Tear_Down;

end Nanomsg.Test_Message_Send_Receive_Million;

--  The MIT License (MIT)

--  Copyright (c) 2015 Pavel Zhukov <landgraf@fedoraproject.org>

--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"), to deal
--  in the Software without restriction, including without limitation the rights
--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--  copies of the Software, and to permit persons to whom the Software is
--  furnished to do so, subject to the following conditions:

--  The above copyright notice and this permission notice shall be included in all
--  copies or substantial portions of the Software.

--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
--  SOFTWARE.

with Ada.Calendar;
with Ada.Text_Io;
with Nanomsg.Domains;
with Nanomsg.Pipeline;
with Aunit.Assertions;
with Nanomsg.Messages;
package body Nanomsg.Test_Message_Send_Receive_Million is

   procedure Run_Test (T : in out TC) is
      use Aunit.Assertions;
      Address : constant String := "tcp://127.0.0.1:5555";
      Msg1 : Nanomsg.Messages.Message_T;
      Msg2 : Nanomsg.Messages.Message_T := Nanomsg.Messages.Empty_Message;
      Begun : Ada.Calendar.Time;
      use type Ada.Calendar.Time;
      Dur : Duration;

      task Sender is
         entry Start;
      end Sender;

      task body Sender is
      begin
         accept Start;
         for X in 1 .. 1_000_000 loop
            T.Socket1.Send (Msg1);
         end loop;
      end Sender;
   begin
      Nanomsg.Messages.From_String (Msg1, "Hello world");
      Nanomsg.Socket.Init (T.Socket1, Nanomsg.Domains.Af_Sp, Nanomsg.Pipeline.Nn_Push);
      Nanomsg.Socket.Init (T.Socket2, Nanomsg.Domains.Af_Sp, Nanomsg.Pipeline.Nn_Pull);
      Assert (Condition => not T.Socket1.Is_Null, Message => "Failed to initialize socket1");
      Assert (Condition => not T.Socket2.Is_Null, Message => "Failed to initialize socket2");
      Assert (Condition => T.Socket1.Get_Fd /= T.Socket2.Get_Fd,
              Message => "Descriptors collision!");
      Nanomsg.Socket.Connect (T.Socket1, Address);
      Nanomsg.Socket.Bind (T.Socket2, "tcp://*:5555");
      Begun := Ada.Calendar.Clock;
      Sender.Start;
      for X in 1 .. 1_000_000 loop
           T.Socket2.Receive (Msg2);
      end loop;
      Dur := Ada.Calendar.Clock - Begun;
      Ada.Text_Io.Put_Line ("Sending of million messages in pipeline mode took: " & Duration'Image (Dur) & " seconds");
      Assert (Condition => Msg1.Text = Msg2.Text,
              Message => "Message transfer failed. Texts are not identical" & Ascii.Lf &
                "Sent: " & Msg1.Text & "; Received: " & Msg2.Text);
   end Run_Test;

   function Name (T : TC) return Message_String is
   begin
      return Aunit.Format ("Test case name : Message send/receive million messages");
   end Name;

   procedure Tear_Down (T : in out Tc) is
   begin
      if T.Socket1.Get_Fd >= 0 then
         T.Socket1.Close;
      end if;
      if T.Socket2.Get_Fd >= 0 then
         T.Socket2.Close;
      end if;
   end Tear_Down;

end Nanomsg.Test_Message_Send_Receive_Million;

Use dedicated thread for "one million test"

Before all messages were sent one by one. This was not right way to work with pipeline sockets.
Using separate thread for sending message reduced time from 14 secs to 1.2 secs