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

package body PortScan.Buildcycle.Ports is

   ---------------------
   --  build_package  --
   ---------------------
   function build_package (id          : builders;
                           sequence_id : port_id;
                           interactive : Boolean := False;
                           interphase  : String  := "") return Boolean
   is
      R : Boolean;
      break_phase  : constant phases := valid_test_phase (interphase);
      run_selftest : constant Boolean := Unix.env_variable_defined (selftest);
   begin
      trackers (id).seq_id := sequence_id;
      trackers (id).loglines := 0;
      if uselog then
         if not initialize_log (id) then
            finalize_log (id);
            return False;
         end if;
      end if;
      for phase in phases'Range loop
         phase_trackers (id) := phase;
         case phase is
            when check_sanity | fetch | checksum | extract | patch |
                 pkg_package =>
               R := exec_phase_generic (id, phase);

            when pkg_depends | fetch_depends | extract_depends |
                 patch_depends | build_depends | lib_depends | run_depends =>
               R := exec_phase_depends (id, phase);

            when configure =>
               if testing then
                  if lock_localbase then
                     set_localbase_protection (id, True);
                  end if;
                  mark_file_system (id, "preconfig");
               end if;
               R := exec_phase_generic (id, phase);

            when build =>
               R := exec_phase_build (id);

            when test =>
               if testing and run_selftest then
                  R := exec_phase_generic (id, phase);
               end if;

            when stage =>
               if testing then
                  mark_file_system (id, "prestage");
               end if;
               R := exec_phase_generic (id, phase);

            when install_mtree | install | check_plist =>
               if testing then
                  R := exec_phase_generic (id, phase);
               end if;

            when deinstall =>
               if testing then
                  R := exec_phase_deinstall (id);
               end if;
         end case;
         exit when R = False;
         exit when interactive and then phase = break_phase;
      end loop;
      if uselog then
         finalize_log (id);
      end if;
      if interactive then
         interact_with_builder (id);
      end if;
      return R;
   end build_package;

   ---------------------------
   --  valid_test_phase #1  --
   ---------------------------
   function valid_test_phase (afterphase : String) return phases is
   begin
      if afterphase = "extract" then
         return extract;
      elsif afterphase = "patch" then
         return patch;
      elsif afterphase = "configure" then
         return configure;
      elsif afterphase = "build" then
         return build;
      elsif afterphase = "stage" then
         return check_plist;
      elsif afterphase = "install" then
         return install;
      elsif afterphase = "deinstall" then
         return deinstall;
      else
         return check_sanity;
      end if;
   end valid_test_phase;

   -----------------
   --  phase2str  --
   -----------------
   function phase2str (phase : phases) return String is
   begin
      case phase is
         when check_sanity    => return "check-sanity";
         when pkg_depends     => return "pkg-depends";
         when fetch_depends   => return "fetch-depends";
         when fetch           => return "fetch";
         when checksum        => return "checksum";
         when extract_depends => return "extract-depends";
         when extract         => return "extract";
         when patch_depends   => return "patch-depends";
         when patch           => return "patch";
         when build_depends   => return "build-depends";
         when lib_depends     => return "lib-depends";
         when configure       => return "configure";
         when build           => return "build";
         when run_depends     => return "run-depends";
         when stage           => return "stage";
         when test            => return "test";
         when pkg_package     => return "package";
         when install_mtree   => return "install-mtree";
         when install         => return "install";
         when deinstall       => return "deinstall";
         when check_plist     => return "check-plist";
      end case;
   end phase2str;

   -------------------------------
   --  max_time_without_output  --
   -------------------------------
   function max_time_without_output (phase : phases) return execution_limit
   is
      base : Integer;
   begin
      case phase is
         when check_sanity     => base := 1;
         when pkg_depends      => base := 3;
         when fetch_depends    => base := 3;
         when fetch | checksum => return 480;  --  8 hours
         when extract_depends  => base := 3;
         when extract          => base := 20;
         when patch_depends    => base := 3;
         when patch            => base := 3;
         when build_depends    => base := 5;
         when lib_depends      => base := 5;
         when configure        => base := 15;
         when build            => base := 25;   --  for gcc linking, tex
         when run_depends      => base := 15;   --  octave-forge is driver
         when stage            => base := 20;   --  desire 15 but too many rogue builders-in-stage
         when test             => base := 25;
         when check_plist      => base := 10;   --  For packages with thousands of files
         when pkg_package      => base := 80;
         when install_mtree    => base := 3;
         when install          => base := 10;
         when deinstall        => base := 10;
      end case;
      declare
         multiplier_x10 : constant Positive := timeout_multiplier_x10;
      begin
         return execution_limit (base * multiplier_x10 / 10);
      end;
   end max_time_without_output;

   --------------------------
   --  exec_phase_generic  --
   --------------------------
   function exec_phase_generic (id : builders; phase : phases) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (phase);
   begin
      return exec_phase (id => id, phase => phase, time_limit => time_limit);
   end exec_phase_generic;

   --------------------------
   --  exec_phase_depends  --
   --------------------------
   function exec_phase_depends (id : builders; phase : phases) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (phase);
      phaseenv : String := "USE_PACKAGE_DEPENDS_ONLY=1";
   begin
      return exec_phase (id => id, phase => phase, phaseenv => phaseenv,
                         time_limit => time_limit,
                         depends_phase => True);
   end exec_phase_depends;

   ------------------
   --  exec_phase  --
   ------------------
   function exec_phase (id : builders; phase : phases;
                        time_limit    : execution_limit;
                        phaseenv      : String := "";
                        depends_phase : Boolean := False;
                        skip_header   : Boolean := False;
                        skip_footer   : Boolean := False)
                        return Boolean
   is
      root       : constant String := get_root (id);
      port_flags : String := " NO_DEPENDS=yes ";
      pid        : port_id := trackers (id).seq_id;
      catport    : constant String := get_catport (all_ports (pid));
      result     : Boolean;
      timed_out  : Boolean;
   begin
      if testing or else depends_phase
      then
         port_flags := (others => LAT.Space);
      end if;

      --  Nasty, we have to switch open and close the log file for each
      --  phase because we have to switch between File_Type and File
      --  Descriptors.  I can't find a safe way to get the File Descriptor
      --  out of the File type.

      if uselog then
         if not skip_header then
            log_phase_begin (phase2str (phase), id);
         end if;
         TIO.Close (trackers (id).log_handle);
      end if;

      declare
         command : constant String := chroot & root & environment_override &
           phaseenv & port_flags & chroot_make_program & " -C " & dir_ports &
           "/" & catport & " " & phase2str (phase);
      begin
         result := generic_execute (id, command, timed_out, time_limit);
      end;

      --  Reopen the log.  I guess we can leave off the exception check
      --  since it's been passing before

      if uselog then
         TIO.Open (File => trackers (id).log_handle,
                   Mode => TIO.Append_File,
                   Name => log_name (trackers (id).seq_id));
         if timed_out then
            TIO.Put_Line (trackers (id).log_handle,
                          "###  Watchdog killed runaway process!  (no activity for" &
                            time_limit'Img & " minutes)  ###");
         end if;
         if not skip_footer then
            log_phase_end (id);
         end if;
      end if;

      return result;
   end exec_phase;

   ------------------------
   --  exec_phase_build  --
   ------------------------
   function exec_phase_build (id : builders) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (build);
      passed : Boolean;
   begin
      passed := exec_phase (id          => id,
                            phase       => build,
                            time_limit  => time_limit,
                            skip_header => False,
                            skip_footer => True);
      if testing and then passed then
         if lock_localbase then
            set_localbase_protection (id, False);
         end if;
         passed := detect_leftovers_and_MIA
           (id, "preconfig", "between port configure and build");
      end if;
      if uselog then
         log_phase_end (id);
      end if;
      return passed;
   end exec_phase_build;

   ----------------------------
   --  exec_phase_deinstall  --
   ----------------------------
   function exec_phase_deinstall (id : builders) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (deinstall);
      result     : Boolean;
   begin
      --  This is only run during "testing" so assume that.
      if uselog then
         log_phase_begin (phase2str (deinstall), id);
         log_linked_libraries (id);
      end if;
      result := exec_phase (id          => id,
                            phase       => deinstall,
                            time_limit  => time_limit,
                            skip_header => True,
                            skip_footer => True);
      if not result then
         if uselog then
            log_phase_end (id);
         end if;
         return False;
      end if;
      if uselog then
         result := detect_leftovers_and_MIA
           (id, "prestage", "between staging and package deinstallation");
         log_phase_end (id);
      end if;
      return result;
   end exec_phase_deinstall;

   ----------------------
   --  builder_status  --
   ----------------------
   function builder_status (id       : builders;
                            shutdown : Boolean := False;
                            idle     : Boolean := False)
                            return Display.builder_rec
   is
      phasestr : constant String := phase2str (phase_trackers (id));
   begin
      return builder_status_core (id       => id,
                                  shutdown => shutdown,
                                  idle     => idle,
                                  phasestr => phasestr);
   end builder_status;

   ------------------------
   --  last_build_phase  --
   ------------------------
   function last_build_phase (id : builders) return String is
   begin
      return phase2str (phase => phase_trackers (id));
   end last_build_phase;

end PortScan.Buildcycle.Ports;

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

package body PortScan.Buildcycle.Ports is

   ---------------------
   --  build_package  --
   ---------------------
   function build_package (id          : builders;
                           sequence_id : port_id;
                           interactive : Boolean := False;
                           interphase  : String  := "") return Boolean
   is
      R : Boolean;
      break_phase  : constant phases := valid_test_phase (interphase);
      run_selftest : constant Boolean := Unix.env_variable_defined (selftest);
   begin
      trackers (id).seq_id := sequence_id;
      trackers (id).loglines := 0;
      if uselog then
         if not initialize_log (id) then
            finalize_log (id);
            return False;
         end if;
      end if;
      for phase in phases'Range loop
         phase_trackers (id) := phase;
         case phase is
            when check_sanity | fetch | checksum | extract | patch |
                 pkg_package =>
               R := exec_phase_generic (id, phase);

            when pkg_depends | fetch_depends | extract_depends |
                 patch_depends | build_depends | lib_depends | run_depends =>
               R := exec_phase_depends (id, phase);

            when configure =>
               if testing then
                  if lock_localbase then
                     set_localbase_protection (id, True);
                  end if;
                  mark_file_system (id, "preconfig");
               end if;
               R := exec_phase_generic (id, phase);

            when build =>
               R := exec_phase_build (id);

            when test =>
               if testing and run_selftest then
                  R := exec_phase_generic (id, phase);
               end if;

            when stage =>
               if testing then
                  mark_file_system (id, "prestage");
               end if;
               R := exec_phase_generic (id, phase);

            when install_mtree | install | check_plist =>
               if testing then
                  R := exec_phase_generic (id, phase);
               end if;

            when deinstall =>
               if testing then
                  R := exec_phase_deinstall (id);
               end if;
         end case;
         exit when R = False;
         exit when interactive and then phase = break_phase;
      end loop;
      if uselog then
         finalize_log (id);
      end if;
      if interactive then
         interact_with_builder (id);
      end if;
      return R;
   end build_package;

   ---------------------------
   --  valid_test_phase #1  --
   ---------------------------
   function valid_test_phase (afterphase : String) return phases is
   begin
      if afterphase = "extract" then
         return extract;
      elsif afterphase = "patch" then
         return patch;
      elsif afterphase = "configure" then
         return configure;
      elsif afterphase = "build" then
         return build;
      elsif afterphase = "stage" then
         return check_plist;
      elsif afterphase = "install" then
         return install;
      elsif afterphase = "deinstall" then
         return deinstall;
      else
         return check_sanity;
      end if;
   end valid_test_phase;

   -----------------
   --  phase2str  --
   -----------------
   function phase2str (phase : phases) return String is
   begin
      case phase is
         when check_sanity    => return "check-sanity";
         when pkg_depends     => return "pkg-depends";
         when fetch_depends   => return "fetch-depends";
         when fetch           => return "fetch";
         when checksum        => return "checksum";
         when extract_depends => return "extract-depends";
         when extract         => return "extract";
         when patch_depends   => return "patch-depends";
         when patch           => return "patch";
         when build_depends   => return "build-depends";
         when lib_depends     => return "lib-depends";
         when configure       => return "configure";
         when build           => return "build";
         when run_depends     => return "run-depends";
         when stage           => return "stage";
         when test            => return "test";
         when pkg_package     => return "package";
         when install_mtree   => return "install-mtree";
         when install         => return "install";
         when deinstall       => return "deinstall";
         when check_plist     => return "check-plist";
      end case;
   end phase2str;

   -------------------------------
   --  max_time_without_output  --
   -------------------------------
   function max_time_without_output (phase : phases) return execution_limit
   is
      base : Integer;
   begin
      case phase is
         when check_sanity     => base := 1;
         when pkg_depends      => base := 3;
         when fetch_depends    => base := 3;
         when fetch | checksum => return 480;  --  8 hours
         when extract_depends  => base := 3;
         when extract          => base := 20;
         when patch_depends    => base := 3;
         when patch            => base := 3;
         when build_depends    => base := 11;   -- for texlive
         when lib_depends      => base := 5;
         when configure        => base := 15;
         when build            => base := 25;   --  for gcc linking, tex
         when run_depends      => base := 15;   --  octave-forge is driver
         when stage            => base := 20;   --  desire 15 but too many rogue builders-in-stage
         when test             => base := 25;
         when check_plist      => base := 10;   --  For packages with thousands of files
         when pkg_package      => base := 80;
         when install_mtree    => base := 3;
         when install          => base := 10;
         when deinstall        => base := 10;
      end case;
      declare
         multiplier_x10 : constant Positive := timeout_multiplier_x10;
      begin
         return execution_limit (base * multiplier_x10 / 10);
      end;
   end max_time_without_output;

   --------------------------
   --  exec_phase_generic  --
   --------------------------
   function exec_phase_generic (id : builders; phase : phases) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (phase);
   begin
      return exec_phase (id => id, phase => phase, time_limit => time_limit);
   end exec_phase_generic;

   --------------------------
   --  exec_phase_depends  --
   --------------------------
   function exec_phase_depends (id : builders; phase : phases) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (phase);
      phaseenv : String := "USE_PACKAGE_DEPENDS_ONLY=1";
   begin
      return exec_phase (id => id, phase => phase, phaseenv => phaseenv,
                         time_limit => time_limit,
                         depends_phase => True);
   end exec_phase_depends;

   ------------------
   --  exec_phase  --
   ------------------
   function exec_phase (id : builders; phase : phases;
                        time_limit    : execution_limit;
                        phaseenv      : String := "";
                        depends_phase : Boolean := False;
                        skip_header   : Boolean := False;
                        skip_footer   : Boolean := False)
                        return Boolean
   is
      root       : constant String := get_root (id);
      port_flags : String := " NO_DEPENDS=yes ";
      pid        : port_id := trackers (id).seq_id;
      catport    : constant String := get_catport (all_ports (pid));
      result     : Boolean;
      timed_out  : Boolean;
   begin
      if testing or else depends_phase
      then
         port_flags := (others => LAT.Space);
      end if;

      --  Nasty, we have to switch open and close the log file for each
      --  phase because we have to switch between File_Type and File
      --  Descriptors.  I can't find a safe way to get the File Descriptor
      --  out of the File type.

      if uselog then
         if not skip_header then
            log_phase_begin (phase2str (phase), id);
         end if;
         TIO.Close (trackers (id).log_handle);
      end if;

      declare
         command : constant String := chroot & root & environment_override &
           phaseenv & port_flags & chroot_make_program & " -C " & dir_ports &
           "/" & catport & " " & phase2str (phase);
      begin
         result := generic_execute (id, command, timed_out, time_limit);
      end;

      --  Reopen the log.  I guess we can leave off the exception check
      --  since it's been passing before

      if uselog then
         TIO.Open (File => trackers (id).log_handle,
                   Mode => TIO.Append_File,
                   Name => log_name (trackers (id).seq_id));
         if timed_out then
            TIO.Put_Line (trackers (id).log_handle,
                          "###  Watchdog killed runaway process!  (no activity for" &
                            time_limit'Img & " minutes)  ###");
         end if;
         if not skip_footer then
            log_phase_end (id);
         end if;
      end if;

      return result;
   end exec_phase;

   ------------------------
   --  exec_phase_build  --
   ------------------------
   function exec_phase_build (id : builders) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (build);
      passed : Boolean;
   begin
      passed := exec_phase (id          => id,
                            phase       => build,
                            time_limit  => time_limit,
                            skip_header => False,
                            skip_footer => True);
      if testing and then passed then
         if lock_localbase then
            set_localbase_protection (id, False);
         end if;
         passed := detect_leftovers_and_MIA
           (id, "preconfig", "between port configure and build");
      end if;
      if uselog then
         log_phase_end (id);
      end if;
      return passed;
   end exec_phase_build;

   ----------------------------
   --  exec_phase_deinstall  --
   ----------------------------
   function exec_phase_deinstall (id : builders) return Boolean
   is
      time_limit : execution_limit := max_time_without_output (deinstall);
      result     : Boolean;
   begin
      --  This is only run during "testing" so assume that.
      if uselog then
         log_phase_begin (phase2str (deinstall), id);
         log_linked_libraries (id);
      end if;
      result := exec_phase (id          => id,
                            phase       => deinstall,
                            time_limit  => time_limit,
                            skip_header => True,
                            skip_footer => True);
      if not result then
         if uselog then
            log_phase_end (id);
         end if;
         return False;
      end if;
      if uselog then
         result := detect_leftovers_and_MIA
           (id, "prestage", "between staging and package deinstallation");
         log_phase_end (id);
      end if;
      return result;
   end exec_phase_deinstall;

   ----------------------
   --  builder_status  --
   ----------------------
   function builder_status (id       : builders;
                            shutdown : Boolean := False;
                            idle     : Boolean := False)
                            return Display.builder_rec
   is
      phasestr : constant String := phase2str (phase_trackers (id));
   begin
      return builder_status_core (id       => id,
                                  shutdown => shutdown,
                                  idle     => idle,
                                  phasestr => phasestr);
   end builder_status;

   ------------------------
   --  last_build_phase  --
   ------------------------
   function last_build_phase (id : builders) return String is
   begin
      return phase2str (phase => phase_trackers (id));
   end last_build_phase;

end PortScan.Buildcycle.Ports;

set the base time limit for build depends to 11 minute (#72)


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

package body ASF.Server.Tests is

   procedure Set_Context (Context : in ASF.Servlets.Servlet_Registry_Access) is
      C : Request_Context;
   begin
      C.Application := Context;
      C.Process     := null;
      ASF.Server.Set_Context (C);
   end Set_Context;

end ASF.Server.Tests;

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

package body ASF.Server.Tests is

   procedure Set_Context (Context : in ASF.Servlets.Servlet_Registry_Access) is
      C : Request_Context;
   begin
      C.Application := Context;
      C.Request     := null;
      C.Response    := null;
      ASF.Server.Set_Context (C);
   end Set_Context;

end ASF.Server.Tests;

Fix compilation of asfunit

Fix compilation of asfunit


--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Interfaces.C.Pointers;

package GL.Types.Colors is
   pragma Preelaborate;

   type Color_Index is (R, G, B, A);
   subtype Basic_Color_Index is Color_Index range R .. B;

   subtype Component is Single range 0.0 .. 1.0;

   type Color is array (Color_Index) of aliased Component;
   type Basic_Color is array (Basic_Color_Index) of Component;

   pragma Convention (C, Color);
   pragma Convention (C, Basic_Color);

   type Enabled_Color is array (Color_Index) of Boolean
     with Convention => C;

   type Color_Array is array (Size range <>) of aliased Color;
   type Basic_Color_Array is array (Size range <>) of aliased Basic_Color;

   package Color_Pointers is new Interfaces.C.Pointers
     (Size, Color, Color_Array, Color'(others => 0.0));
   package Basic_Color_Pointers is new Interfaces.C.Pointers
     (Size, Basic_Color, Basic_Color_Array, Basic_Color'(others => 0.0));

end GL.Types.Colors;

--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Interfaces.C.Pointers;

package GL.Types.Colors is
   pragma Preelaborate;

   type Color_Index is (R, G, B, A);

   subtype Component is Single range 0.0 .. 1.0;

   type Color is array (Color_Index) of aliased Component;

   pragma Convention (C, Color);

   type Enabled_Color is array (Color_Index) of Boolean
     with Convention => C;

   type Color_Array is array (Size range <>) of aliased Color;

   package Color_Pointers is new Interfaces.C.Pointers
     (Size, Color, Color_Array, Color'(others => 0.0));

end GL.Types.Colors;

Remove unused type Basic_Color

gl: Remove unused type Basic_Color

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

--  === Rolling file appender ===
--  The `RollingFile` appender recognises the following configurations:
--
--  | Name           | Description                                                          |
--  | -------------- | --------------------------------------------------------------       |
--  | layout         | Defines the format of the message printed by the appender.           |
--  | level          | Defines the minimum level above which messages are printed.          |
--  | fileName       | The name of the file to write to. If the file, or any of its parent  |
--  |                | directories, do not exist, they will be created.                     |
--  | filePattern    | The pattern of the file name of the archived log file.  The pattern  |
--  |                | can contain '%i' which are replaced by a counter incremented at each |
--  |                | rollover, a '%d' is replaced by a date pattern.                      |
--  | append         | When 'true' or '1', the file is opened in append mode otherwise      |
--  |                | it is truncated (the default is to truncate).                        |
--  | immediateFlush | When 'true' or '1', the file is flushed after each message log.      |
--  |                | Immediate flush is useful in some situations to have the log file    |
--  |                | updated immediately at the expense of slowing down the processing    |
--  |                | of logs.                                                             |
--  | policy         | The triggering policy which drives when a rolling is performed.      |
--  |                | Possible values are: `none`, `size`, `time`                          |
--  | strategy       | The strategy to use to determine the name and location of the        |
--  |                | archive file.  Possible values are: `ascending`, `descending`, and   |
--  |                | `direct`.  Default is `ascending`.                                   |
--  | policyInterval | How often a rollover should occur based on the most specific time    |
--  |                | unit in the date pattern. For example, with a date pattern with      |
--  |                | hours as the most specific item and and increment of 4 rollovers     |
--  |                | would occur every 4 hours. The default value is 1.                   |
--  | policyMin      | The minimum value of the counter. The default value is 1.            |
--  | policyMax      | The maximum value of the counter. Once this values is reached older  |
--  |                | archives will be deleted on subsequent rollovers. The default        |
--  |                | value is 7.                                                          |
--  | minSize        | The minimum size the file must have to roll over.                    |
package Util.Log.Appenders.Rolling_Files is

   --  ------------------------------
   --  File appender
   --  ------------------------------
   type File_Appender (Length : Positive) is new Appender with private;
   type File_Appender_Access is access all File_Appender'Class;

   overriding
   procedure Append (Self    : in out File_Appender;
                     Message : in Util.Strings.Builders.Builder;
                     Date    : in Ada.Calendar.Time;
                     Level   : in Level_Type;
                     Logger  : in String);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out File_Appender);

   --  Flush and close the file.
   overriding
   procedure Finalize (Self : in out File_Appender);

   --  Create a file appender and configure it according to the properties
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
     return Appender_Access;

private

   type File_Entity is new Util.Refs.Ref_Entity with record
      Output          : Ada.Text_IO.File_Type;
   end record;
   type File_Access is access all File_Entity;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out File_Entity);

   package File_Refs is new Util.Refs.References (File_Entity, File_Access);

   protected type Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager);

      procedure Openlog (File : out File_Refs.Ref);

      procedure Flush (File : out File_Refs.Ref);

      procedure Closelog;

   private
      Manager    : Util.Files.Rolling.File_Manager;
      Current    : File_Refs.Ref;
      Append     : Boolean;
   end Rolling_File;

   type File_Appender (Length : Positive) is new Appender (Length) with record
      Immediate_Flush : Boolean := False;
      File            : Rolling_File;
   end record;

end Util.Log.Appenders.Rolling_Files;

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

--  === Rolling file appender ===
--  The `RollingFile` appender recognises the following configurations:
--
--  | Name           | Description                                                          |
--  | -------------- | --------------------------------------------------------------       |
--  | layout         | Defines the format of the message printed by the appender.           |
--  | level          | Defines the minimum level above which messages are printed.          |
--  | fileName       | The name of the file to write to. If the file, or any of its parent  |
--  |                | directories, do not exist, they will be created.                     |
--  | filePattern    | The pattern of the file name of the archived log file.  The pattern  |
--  |                | can contain '%i' which are replaced by a counter incremented at each |
--  |                | rollover, a '%d' is replaced by a date pattern.                      |
--  | append         | When 'true' or '1', the file is opened in append mode otherwise      |
--  |                | it is truncated (the default is to truncate).                        |
--  | immediateFlush | When 'true' or '1', the file is flushed after each message log.      |
--  |                | Immediate flush is useful in some situations to have the log file    |
--  |                | updated immediately at the expense of slowing down the processing    |
--  |                | of logs.                                                             |
--  | policy         | The triggering policy which drives when a rolling is performed.      |
--  |                | Possible values are: `none`, `size`, `time`, `size-time`             |
--  | strategy       | The strategy to use to determine the name and location of the        |
--  |                | archive file.  Possible values are: `ascending`, `descending`, and   |
--  |                | `direct`.  Default is `ascending`.                                   |
--  | policyInterval | How often a rollover should occur based on the most specific time    |
--  |                | unit in the date pattern.  This indicates the period in seconds      |
--  |                | to check for pattern change in the `time` or `size-time` policy.     |
--  | policyMin      | The minimum value of the counter. The default value is 1.            |
--  | policyMax      | The maximum value of the counter. Once this values is reached older  |
--  |                | archives will be deleted on subsequent rollovers. The default        |
--  |                | value is 7.                                                          |
--  | minSize        | The minimum size the file must have to roll over.                    |
--
--  A typical rolling file configuration would look like:
--
--    log4j.rootCategory=DEBUG,applogger,apperror
--    log4j.appender.applogger=RollingFile
--    log4j.appender.applogger.layout=level-message
--    log4j.appender.applogger.level=DEBUG
--    log4j.appender.applogger.fileName=logs/debug.log
--    log4j.appender.applogger.filePattern=logs/debug-%d{YYYY-MM}/debug-%{dd}-%i.log
--    log4j.appender.applogger.strategy=descending
--    log4j.appender.applogger.policy=time
--    log4j.appender.applogger.policyMax=10
--    log4j.appender.apperror=RollingFile
--    log4j.appender.apperror.layout=level-message
--    log4j.appender.apperror.level=ERROR
--    log4j.appender.apperror.fileName=logs/error.log
--    log4j.appender.apperror.filePattern=logs/error-%d{YYYY-MM}/error-%{dd}.log
--    log4j.appender.apperror.strategy=descending
--    log4j.appender.apperror.policy=time
--
--  With this configuration, the error messages are written in the `error.log` file and
--  they are rotated on a day basis and moved in a directory whose name contains the year
--  and month number.  At the same time, debug messages are written in the `debug.log`
--  file.
package Util.Log.Appenders.Rolling_Files is

   --  ------------------------------
   --  File appender
   --  ------------------------------
   type File_Appender (Length : Positive) is new Appender with private;
   type File_Appender_Access is access all File_Appender'Class;

   overriding
   procedure Append (Self    : in out File_Appender;
                     Message : in Util.Strings.Builders.Builder;
                     Date    : in Ada.Calendar.Time;
                     Level   : in Level_Type;
                     Logger  : in String);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out File_Appender);

   --  Flush and close the file.
   overriding
   procedure Finalize (Self : in out File_Appender);

   --  Create a file appender and configure it according to the properties
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
     return Appender_Access;

private

   type File_Entity is new Util.Refs.Ref_Entity with record
      Output          : Ada.Text_IO.File_Type;
   end record;
   type File_Access is access all File_Entity;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out File_Entity);

   package File_Refs is new Util.Refs.References (File_Entity, File_Access);

   protected type Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager);

      procedure Openlog (File : out File_Refs.Ref);

      procedure Flush (File : out File_Refs.Ref);

      procedure Closelog;

   private
      Manager    : Util.Files.Rolling.File_Manager;
      Current    : File_Refs.Ref;
      Append     : Boolean;
   end Rolling_File;

   type File_Appender (Length : Positive) is new Appender (Length) with record
      Immediate_Flush : Boolean := False;
      File            : Rolling_File;
   end record;

end Util.Log.Appenders.Rolling_Files;

Update the documentation for rolling file appender


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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         begin
            Controller.Controllers (Phase).Execute (Context);
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;

         --  If exceptions have been raised and queued during the current phase, process them.
         --  An exception handler could use them to redirect the current request to another
         --  page or navigate to a specific view.
         declare
            Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
              := Context.Get_Exception_Handler;
         begin
            if Ex /= null then
               Ex.Handle;
            end if;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

end ASF.Lifecycles;

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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         begin
            Context.Set_Current_Phase (Phase);
            Controller.Controllers (Phase).Execute (Context);
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;

         --  If exceptions have been raised and queued during the current phase, process them.
         --  An exception handler could use them to redirect the current request to another
         --  page or navigate to a specific view.
         declare
            Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
              := Context.Get_Exception_Handler;
         begin
            if Ex /= null then
               Ex.Handle;
            end if;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Context.Set_Current_Phase (ASF.Events.Phases.RENDER_RESPONSE);
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

end ASF.Lifecycles;

Set the lifecycle phase in the faces context before executing each lifecycle operation


--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Interfaces.C.Strings;

with GL.API;
with GL.Enums;

package body GL.Objects.Shaders is

   procedure Set_Source (Subject : Shader; Source : String) is
      C_Shader_Source : C.Strings.chars_ptr := C.Strings.New_String (Source);
      C_Source : constant Low_Level.CharPtr_Array
        := (1 => C_Shader_Source);
      Lengths : constant Low_Level.Int_Array
        := (1 => Source'Length);
   begin
      API.Shader_Source (Subject.Reference.GL_Id, 1, C_Source, Lengths);
      C.Strings.Free (C_Shader_Source);
      Raise_Exception_On_OpenGL_Error;
   end Set_Source;

   function Source (Subject : Shader) return String is
      Source_Length : Size := 0;
   begin
      API.Get_Shader_Param (Subject.Reference.GL_Id,
                            Enums.Shader_Source_Length, Source_Length);
      declare
         Shader_Source : String (1 .. Integer (Source_Length));
         -- do not care that we do not assign a value.
         pragma Warnings (Off, Shader_Source);
         C_Shader_Source : C.Strings.chars_ptr
           := C.Strings.New_String (Shader_Source);
         Actual_Length : Size;
      begin
         API.Get_Shader_Source (Subject.Reference.GL_Id, Source_Length,
                                Actual_Length, C_Shader_Source);
         Shader_Source
           := C.Strings.Value (C_Shader_Source, C.size_t (Actual_Length));
         C.Strings.Free (C_Shader_Source);
         return Shader_Source;
      end;
   end Source;

   procedure Compile (Subject : Shader) is
   begin
      API.Compile_Shader (Subject.Reference.GL_Id);
      Raise_Exception_On_OpenGL_Error;
   end Compile;

   procedure Release_Shader_Compiler renames API.Release_Shader_Compiler;

   function Compile_Status (Subject : Shader) return Boolean is
      Value : Int := 0;
   begin
      API.Get_Shader_Param (Subject.Reference.GL_Id, Enums.Compile_Status,
                            Value);
      return Value /= 0;
   end Compile_Status;

   function Info_Log (Subject : Shader) return String is
      Log_Length : Size := 0;
   begin
      API.Get_Shader_Param (Subject.Reference.GL_Id,
                            Enums.Info_Log_Length, Log_Length);
      -- Returned length includes null termination character
      Log_Length := Log_Length - 1;
      declare
         Info_Log : String (1 .. Integer (Log_Length));
         pragma Warnings (Off, Info_Log);
         C_Info_Log : C.Strings.chars_ptr
           := C.Strings.New_String (Info_Log);
         Actual_Length : Size;
      begin
         API.Get_Shader_Info_Log (Subject.Reference.GL_Id, Log_Length + 1,
           Actual_Length, C_Info_Log);
         if Int (Actual_Length) /= Log_Length then
            raise Constraint_Error with "Expected info log length of" &
                                        Size'Image (Log_Length) & ", actually got" &
                                        Size'Image (Actual_Length) & ".";
         end if;
         Info_Log := C.Strings.Value (C_Info_Log, C.size_t (Actual_Length));
         C.Strings.Free (C_Info_Log);
         return Info_Log;
      end;
   end Info_Log;

   overriding
   procedure Initialize_Id (Object : in out Shader) is
   begin
      Object.Reference.GL_Id := API.Create_Shader (Object.Kind);
      Object.Reference.Initialized := True;
   end Initialize_Id;

   overriding
   procedure Delete_Id (Object : in out Shader) is
   begin
      API.Delete_Shader (Object.Reference.GL_Id);
      Object.Reference.GL_Id := 0;
      Object.Reference.Initialized := False;
   end Delete_Id;

   function Create_From_Id (Id : UInt) return Shader is
      Kind : Shader_Type := Shader_Type'First;
   begin
      API.Get_Shader_Type (Id, Enums.Shader_Type, Kind);
      Raise_Exception_On_OpenGL_Error;
      return Object : Shader (Kind) do
         Object.Reference.GL_Id := Id;
         Object.Reference.Initialized := True;
      end return;
   end Create_From_Id;

end GL.Objects.Shaders;

--  Copyright (c) 2012 Felix Krause <contact@flyx.org>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Interfaces.C.Strings;

with GL.API;
with GL.Enums;

package body GL.Objects.Shaders is

   procedure Set_Source (Subject : Shader; Source : String) is
      C_Shader_Source : C.Strings.chars_ptr := C.Strings.New_String (Source);
      C_Source : constant Low_Level.CharPtr_Array
        := (1 => C_Shader_Source);
      Lengths : constant Low_Level.Int_Array
        := (1 => Source'Length);
   begin
      API.Shader_Source (Subject.Reference.GL_Id, 1, C_Source, Lengths);
      C.Strings.Free (C_Shader_Source);
      Raise_Exception_On_OpenGL_Error;
   end Set_Source;

   function Source (Subject : Shader) return String is
      Source_Length : Size := 0;
   begin
      API.Get_Shader_Param (Subject.Reference.GL_Id,
                            Enums.Shader_Source_Length, Source_Length);
      declare
         Shader_Source : String (1 .. Integer (Source_Length));
         --  Do not care that we do not assign a value.
         pragma Warnings (Off, Shader_Source);
         C_Shader_Source : C.Strings.chars_ptr
           := C.Strings.New_String (Shader_Source);
         Actual_Length : Size;
      begin
         API.Get_Shader_Source (Subject.Reference.GL_Id, Source_Length,
                                Actual_Length, C_Shader_Source);
         Shader_Source
           := C.Strings.Value (C_Shader_Source, C.size_t (Actual_Length));
         C.Strings.Free (C_Shader_Source);
         return Shader_Source;
      end;
   end Source;

   procedure Compile (Subject : Shader) is
   begin
      API.Compile_Shader (Subject.Reference.GL_Id);
      Raise_Exception_On_OpenGL_Error;
   end Compile;

   procedure Release_Shader_Compiler renames API.Release_Shader_Compiler;

   function Compile_Status (Subject : Shader) return Boolean is
      Value : Int := 0;
   begin
      API.Get_Shader_Param (Subject.Reference.GL_Id, Enums.Compile_Status,
                            Value);
      return Value /= 0;
   end Compile_Status;

   function Info_Log (Subject : Shader) return String is
      Log_Length : Size := 0;
   begin
      API.Get_Shader_Param (Subject.Reference.GL_Id,
                            Enums.Info_Log_Length, Log_Length);

      if Log_Length = 0 then
         return "";
      end if;

      --  Returned length includes null termination character
      Log_Length := Log_Length - 1;
      declare
         Info_Log : String (1 .. Integer (Log_Length));
         pragma Warnings (Off, Info_Log);
         C_Info_Log : C.Strings.chars_ptr
           := C.Strings.New_String (Info_Log);
         Actual_Length : Size;
      begin
         API.Get_Shader_Info_Log (Subject.Reference.GL_Id, Log_Length + 1,
           Actual_Length, C_Info_Log);
         if Int (Actual_Length) /= Log_Length then
            raise Constraint_Error with "Expected info log length of" &
                                        Size'Image (Log_Length) & ", actually got" &
                                        Size'Image (Actual_Length) & ".";
         end if;
         Info_Log := C.Strings.Value (C_Info_Log, C.size_t (Actual_Length));
         C.Strings.Free (C_Info_Log);
         return Info_Log;
      end;
   end Info_Log;

   overriding
   procedure Initialize_Id (Object : in out Shader) is
   begin
      Object.Reference.GL_Id := API.Create_Shader (Object.Kind);
      Object.Reference.Initialized := True;
   end Initialize_Id;

   overriding
   procedure Delete_Id (Object : in out Shader) is
   begin
      API.Delete_Shader (Object.Reference.GL_Id);
      Object.Reference.GL_Id := 0;
      Object.Reference.Initialized := False;
   end Delete_Id;

   function Create_From_Id (Id : UInt) return Shader is
      Kind : Shader_Type := Shader_Type'First;
   begin
      API.Get_Shader_Type (Id, Enums.Shader_Type, Kind);
      Raise_Exception_On_OpenGL_Error;
      return Object : Shader (Kind) do
         Object.Reference.GL_Id := Id;
         Object.Reference.Initialized := True;
      end return;
   end Create_From_Id;

end GL.Objects.Shaders;

gl: Fix raise Contraint_Error if info log is empty

When no shader info log exists, 0 is returned as length. This produced a
Constraint_Error because we substracted 1 from it (null terminator).

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with Util.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;

with ASF.Applications;

--  == Introduction ==
--  The <b>AWA.Jobs</b> plugin defines a batch job framework for modules to perform and execute
--  long running and deferred actions.
--
--
--  == Data Model ==
--  @include jobs.hbm.xml
--
package AWA.Jobs is

end AWA.Jobs;

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

--  == Introduction ==
--  The AWA.Jobs plugin defines a batch job framework for modules to perform and execute
--  long running and deferred actions.  The `Jobs` plugin is intended to help web application
--  designers in implementing end to end asynchronous operation.  A client schedules a job
--  and does not block nor wait for the immediate completion.  Instead, the client asks
--  periodically or uses other mechanisms to check for the job completion.
--
--  === Writing a job ===
--  A new job type is created by implementing the `Execute` operation of the abstract
--  `Job_Type` tagged record.
--
--    type Resize_Job is new AWA.Jobs.Job_Type with ...;
--
--  The `Execute` procedure must be implemented.  It should use the `Get_Parameter` functions
--  to retrieve the job parameters and perform the work.  While the job is being executed,
--  it can save result by using the `Set_Result` operations, save messages by using the
--  `Set_Message` operations and report the progress by using `Set_Progress`.
--  It may report the job status by using `Set_Status`.
--
--    procedure Execute (Job : in out Resize_Job) is
--    begin
--        Job.Set_Result ("done", "ok");
--    end Execute;
--
--  === Registering a job ===
--  The AWA.Jobs plugin must be able to create the job instance when it is going to
--  be executed.  For this, a registration package must be instantiated:
--
--    package Resize_Def is new AWA.Jobs.Definition (Resize_Job);
--
--  === Scheduling a job ===
--  To schedule a job, declare an instance of the job to execute and set the job specific
--  parameters.  The job parameters will be saved in the database.  As soon as parameters
--  are defined, call the `Schedule` procedure to schedule the job in the job queue and
--  obtain a job identifier.
--
--    Resize : Resize_Job;
--    ...
--    Resize.Set_Parameter ("file", "image.png");
--    Resize.Set_Parameter ("width", "32");
--    Resize.Set_Parameter ("height, "32");
--    Resize.Schedule;
--
--  === Checking for job completion ===
--
--
--  == Data Model ==
--  @include jobs.hbm.xml
--
package AWA.Jobs is

end AWA.Jobs;

Document the new AWA jobs plugin

Document the new AWA jobs plugin


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

with ASF.Applications;

with AWA.Modules;
with AWA.Jobs.Services;
with AWA.Events.Models;

--  == Job Module ==
--  The Jobs.Modules is the entry point for the management of asynchronous jobs.
--  It maintains a list of job types that can be executed for the application and it
--  manages the job dispatchers.
package AWA.Jobs.Modules is

   NAME : constant String := "jobs";

   type Job_Module is new AWA.Modules.Module with private;
   type Job_Module_Access is access all Job_Module'Class;

   --  Initialize the job module.
   overriding
   procedure Initialize (Plugin : in out Job_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the job module instance associated with the current application.
   function Get_Job_Module return Job_Module_Access;

   --  Registers the job work procedure represented by Work under the name Name.
   procedure Register (Plugin     : in out Job_Module;
                       Definition : in AWA.Jobs.Services.Job_Factory_Access);

   --  Find the job work factory registered under the name Name.
   --  Returns null if there is no such factory.
   function Find_Factory (Plugin : in Job_Module;
                          Name   : in String) return AWA.Jobs.Services.Job_Factory_Access;

   --  Create an event to schedule the job execution.
   procedure Create_Event (Event : in out AWA.Events.Models.Message_Ref);

private

   use AWA.Jobs.Services;

   --  A factory map to create job instances.
   package Job_Factory_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Job_Factory_Access,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   type Job_Module is new AWA.Modules.Module with record
      Factory      : Job_Factory_Map.Map;
      Queue        : AWA.Events.Models.Queue_Ref;
      Message_Type : AWA.Events.Models.Message_Type_Ref;
   end record;

end AWA.Jobs.Modules;

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

with ASF.Applications;

with AWA.Modules;
with AWA.Jobs.Services;

--  == Job Module ==
--  The <b>Jobs.Modules</b> is the entry point for the management of asynchronous jobs.
--  It maintains a list of job types that can be executed for the application and it
--  manages the job dispatchers.
package AWA.Jobs.Modules is

   NAME : constant String := "jobs";

   type Job_Module is new AWA.Modules.Module with private;
   type Job_Module_Access is access all Job_Module'Class;

   --  Initialize the job module.
   overriding
   procedure Initialize (Plugin : in out Job_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the job module instance associated with the current application.
   function Get_Job_Module return Job_Module_Access;

   --  Registers the job work procedure represented by `Work` under the name `Name`.
   procedure Register (Plugin     : in out Job_Module;
                       Definition : in AWA.Jobs.Services.Job_Factory_Access);

   --  Find the job work factory registered under the name `Name`.
   --  Returns null if there is no such factory.
   function Find_Factory (Plugin : in Job_Module;
                          Name   : in String) return AWA.Jobs.Services.Job_Factory_Access;

private

   use AWA.Jobs.Services;

   --  A factory map to create job instances.
   package Job_Factory_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Job_Factory_Access,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   type Job_Module is new AWA.Modules.Module with record
      Factory      : Job_Factory_Map.Map;
   end record;

end AWA.Jobs.Modules;

Remove the Create_Event procedure as well as unused members in the Job module


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

with MAT.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural;
      Total_Alloc   : MAT.Types.Target_Size;
      Total_Free    : MAT.Types.Target_Size;
      Malloc_Count  : Natural;
      Free_Count    : Natural;
      Realloc_Count : Natural;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation);

   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation);

      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Stats         : Memory_Stat;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

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

with MAT.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural;
      Total_Alloc   : MAT.Types.Target_Size;
      Total_Free    : MAT.Types.Target_Size;
      Malloc_Count  : Natural;
      Free_Count    : Natural;
      Realloc_Count : Natural;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation);

   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation);

      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

      --  Get the global memory and allocation statistics.
      procedure Stat_Information (Result : out Memory_Stat);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Stats         : Memory_Stat;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

Declare the Stat_Information protected operation