ADDED src/natools-cron.adb Index: src/natools-cron.adb ================================================================== --- src/natools-cron.adb +++ src/natools-cron.adb @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2014, 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. -- +------------------------------------------------------------------------------ + +package body Natools.Cron is + + ------------------------ + -- Helper Subprograms -- + ------------------------ + + function "<" (Left, Right : Periodic_Time) return Boolean is + use type Ada.Calendar.Time; + begin + return Left.Origin < Right.Origin + or else (Left.Origin = Right.Origin + and then Left.Period < Right.Period); + end "<"; + + + + ---------------------- + -- Public Interface -- + ---------------------- + + function Create + (Time : in Periodic_Time; + Callback : in Cron.Callback'Class) + return Cron_Entry is + begin + return Result : Cron_Entry do + Result.Set (Time, Callback); + end return; + end Create; + + + function Create + (Period : in Duration; + Callback : in Cron.Callback'Class) + return Cron_Entry is + begin + return Result : Cron_Entry do + Result.Set (Period, Callback); + end return; + end Create; + + + procedure Set + (Self : in out Cron_Entry; + Time : in Periodic_Time; + Callback : in Cron.Callback'Class) + is + function Create return Cron.Callback'Class; + + function Create return Cron.Callback'Class is + begin + return Callback; + end Create; + begin + Self.Reset; + Self.Callback.Replace (Create'Access); + Database.Insert (Time, Self.Callback); + end Set; + + + procedure Set + (Self : in out Cron_Entry; + Period : in Duration; + Callback : in Cron.Callback'Class) is + begin + Set (Self, (Ada.Calendar.Clock, Period), Callback); + end Set; + + + overriding procedure Finalize (Object : in out Cron_Entry) is + begin + if not Object.Callback.Is_Empty then + Object.Reset; + end if; + end Finalize; + + + procedure Reset (Self : in out Cron_Entry) is + begin + if not Self.Callback.Is_Empty then + Database.Remove (Self.Callback); + Self.Callback.Reset; + end if; + end Reset; + + + + ------------------------ + -- Protected Database -- + ------------------------ + + protected body Database is + procedure Insert + (Time : in Periodic_Time; + Callback : in Callback_Refs.Reference) + is + use type Ada.Calendar.Time; + + Now : constant Ada.Calendar.Time := Ada.Calendar.Clock; + Actual_Time : Periodic_Time := Time; + begin + while Actual_Time.Origin < Now loop + Actual_Time.Origin := Actual_Time.Origin + Actual_Time.Period; + end loop; + + if Map.Is_Empty then + if Global_Worker /= null and then Global_Worker.all'Terminated then + Unchecked_Free (Global_Worker); + end if; + + if Global_Worker = null then + Global_Worker := new Worker; + end if; + else + if Actual_Time < Map.First_Key then + First_Changed := True; + end if; + end if; + + Map.Insert (Actual_Time, Callback); + end Insert; + + + procedure Remove (Callback : in Callback_Refs.Reference) is + use type Callback_Refs.Reference; + + Cursor : Entry_Maps.Cursor := Map.First; + Is_First : Boolean := True; + begin + while Entry_Maps.Has_Element (Cursor) loop + if Entry_Maps.Element (Cursor) = Callback then + Map.Delete (Cursor); + + if Is_First then + First_Changed := True; + end if; + + exit; + end if; + + Entry_Maps.Next (Cursor); + Is_First := False; + end loop; + end Remove; + + + procedure Update (Callback : in Callback_Refs.Reference) is + use type Callback_Refs.Reference; + Cursor : Entry_Maps.Cursor := Map.First; + begin + Search : + while Entry_Maps.Has_Element (Cursor) loop + if Entry_Maps.Element (Cursor) = Callback then + declare + Old_Time : constant Periodic_Time := Entry_Maps.Key (Cursor); + begin + Map.Delete (Cursor); + Insert (Old_Time, Callback); + end; + + exit Search; + end if; + + Entry_Maps.Next (Cursor); + end loop Search; + end Update; + + + procedure Get_First + (Time : out Periodic_Time; + Callback : out Callback_Refs.Reference) + is + Cursor : constant Entry_Maps.Cursor := Map.First; + begin + if Entry_Maps.Has_Element (Cursor) then + Time := Entry_Maps.Key (Cursor); + Callback := Entry_Maps.Element (Cursor); + else + Callback := Callback_Refs.Null_Reference; + end if; + + First_Changed := False; + end Get_First; + + + entry Update_Notification when First_Changed is + begin + null; + end Update_Notification; + + end Database; + + + + ----------------- + -- Worker Task -- + ----------------- + + task body Worker is + Time : Periodic_Time; + Callback : Callback_Refs.Reference; + Waiting : Boolean; + begin + Main : + loop + Waiting := True; + + Wait_Loop : + while Waiting loop + Database.Get_First (Time, Callback); + exit Main when Callback.Is_Empty; + + select + Database.Update_Notification; + or + delay until Time.Origin; + Waiting := False; + end select; + end loop Wait_Loop; + + Callback.Update.Data.Run; + Database.Update (Callback); + end loop Main; + end Worker; + +end Natools.Cron; ADDED src/natools-cron.ads Index: src/natools-cron.ads ================================================================== --- src/natools-cron.ads +++ src/natools-cron.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2014, 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.Cron is a low-overhead, low-precision implementation of periodic -- +-- callbacks, similar to UNIX cron daemon. -- +-- Note that callbacks are executed sequentially in a single thread, and -- +-- ticks may be skipped when computing resources lack. -- +-- If you need more precision and/or more reliability, you might want to -- +-- consider using Ada.Real_Time.Timing_Events instead. -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +private with Ada.Containers.Ordered_Maps; +private with Ada.Finalization; +private with Ada.Unchecked_Deallocation; +private with Natools.References; +private with Natools.Storage_Pools; + +package Natools.Cron is + + type Callback is interface; + + procedure Run (Object : in out Callback) is abstract; + + + type Periodic_Time is record + Origin : Ada.Calendar.Time; + Period : Duration; + end record; + + + type Cron_Entry is tagged limited private; + + function Create + (Time : in Periodic_Time; + Callback : in Cron.Callback'Class) + return Cron_Entry; + -- Create a new entry with the given parameters + + function Create + (Period : in Duration; + Callback : in Cron.Callback'Class) + return Cron_Entry; + -- Create a new entry starting within a period from now + + procedure Set + (Self : in out Cron_Entry; + Time : in Periodic_Time; + Callback : in Cron.Callback'Class); + -- Reset an entry with the given parameters + + procedure Set + (Self : in out Cron_Entry; + Period : in Duration; + Callback : in Cron.Callback'Class); + -- Reset entry with the given parameters, starting one period from now + + procedure Reset (Self : in out Cron_Entry); + -- Clear internal state and remove associated entry from database. + -- Note that if the callback procedure is currently running, it will + -- continue until it returns, so the callback object may outlive + -- the call to Reset, plan concurrency accordingly. + +private + + package Callback_Refs is new References + (Callback'Class, + Storage_Pools.Access_In_Default_Pool'Storage_Pool, + Storage_Pools.Access_In_Default_Pool'Storage_Pool); + + + type Cron_Entry is new Ada.Finalization.Limited_Controlled with record + Callback : Callback_Refs.Reference; + end record; + + overriding procedure Finalize (Object : in out Cron_Entry); + + + function "<" (Left, Right : Periodic_Time) return Boolean; + -- Comparison function for ordered map + + package Entry_Maps is new Ada.Containers.Ordered_Maps + (Periodic_Time, Callback_Refs.Reference, "<", Callback_Refs."="); + + + protected Database is + procedure Insert + (Time : in Periodic_Time; + Callback : in Callback_Refs.Reference); + -- Insert Callback into the database, adjusting Time.Origin + -- to be in the future. + + procedure Remove (Callback : in Callback_Refs.Reference); + -- Remove Callback from the database + + procedure Update (Callback : in Callback_Refs.Reference); + -- Update Time.Origin associated with Callback so that + -- it is in the future. + + procedure Get_First + (Time : out Periodic_Time; + Callback : out Callback_Refs.Reference); + -- Return the next active callback, or an empty reference when + -- the database is empty (to signal task termination). + + entry Update_Notification; + -- Block as long as the next active item does not change + + private + Map : Entry_Maps.Map; + First_Changed : Boolean := False; + end Database; + + task type Worker is + end Worker; + + type Worker_Access is access Worker; + + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Worker, Worker_Access); + + Global_Worker : Worker_Access := null; + +end Natools.Cron;