-----------------------------------------------------------------------
--  ADO Sessions -- Sessions Management
--  Copyright (C) 2009, 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.Finalization;

with ADO.Schemas;
with ADO.Statements;
with ADO.Objects;
with ADO.Objects.Cache;
with ADO.Databases;
with ADO.Queries;
with ADO.SQL;

with Util.Concurrent.Counters;
limited with ADO.Sequences;
limited with ADO.Schemas.Entities;

package ADO.Sessions is

   use ADO.Statements;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   --  Raised if the database connection is not open.
   NOT_OPEN : exception;

   NOT_FOUND : exception;

   NO_DATABASE : exception;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   type Object_Factory is tagged private;

   --  ---------
   --  Session
   --  ---------
   --  Read-only database connection (or slave connection).
   --
   type Session is tagged private;

   --  Get the session status.
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status;

   --  Close the session.
   procedure Close (Database : in out Session);

   --  Get the database connection.
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class;

   --  Attach the object to the session.
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class);

   --  Check if the session contains the object identified by the given key.
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean;

   --  Remove the object from the session cache.
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key);

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement;

   --  Create a query statement and initialize the SQL statement with the query definition.
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  ---------
   --  Master Session
   --  ---------
   --  Read-write session.
   --
   type Master_Session is new Session with private;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Master_Session);

   --  Commit the current transaction.
   procedure Commit (Database : in out Master_Session);

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Master_Session);

   --  Allocate an identifier for the table.
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class);

   --  Flush the objects that were modified.
   procedure Flush (Database : in out Master_Session);

   --  Create a delete statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement;

   --  Create an update statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement;

   --  Create an insert statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement;

   type Session_Proxy is limited private;
   type Session_Proxy_Access is access all Session_Proxy;

   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access;

   type Session_Record is limited private;
   type Session_Record_Access is access all Session_Record;

private

   type Entity_Cache_Access is access constant ADO.Schemas.Entities.Entity_Cache;

   type Object_Factory is tagged record
      A : Integer;
   end record;
   type Object_Factory_Access is access all Object_Factory'Class;

   type Session_Proxy is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Session : Session_Record_Access;
      Factory : Object_Factory_Access;
   end record;

   --  The Session_Record maintains the connection information to the database for
   --  the duration of the session.  It also maintains a cache of application objects
   --  which is used when session objects are fetched (either through Load or a Find).
   --  The connection is released and the session record is deleted when the session
   --  is closed with Close.
   --
   --  For the lazy loading support, each object is associated with a shared Session_Proxy
   --  object that allows to give access to the session record associated with the object.
   --  When a session is closed, the Session_Proxy is not deleted but it is simply
   --  unlinked from the session record.
   type Session_Record is limited record
      Counter  : Natural := 1;
      Database : ADO.Databases.Master_Connection;
      Proxy    : ADO.Objects.Session_Proxy_Access;
      Cache    : ADO.Objects.Cache.Object_Cache;
      Entities : Entity_Cache_Access;
   end record;

   type Session is new Ada.Finalization.Controlled with record
      Impl : Session_Record_Access := null;
   end record;

   overriding
   procedure Adjust (Object : in out Session);

   overriding
   procedure Finalize (Object : in out Session);

   type Factory_Access is access ADO.Sequences.Factory;

   type Master_Session is new Session with record
      Sequences : Factory_Access;
   end record;

   procedure Check_Session (Database : in Session'Class);
   pragma Inline (Check_Session);

end ADO.Sessions;

-----------------------------------------------------------------------
--  ADO Sessions -- Sessions Management
--  Copyright (C) 2009, 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.Finalization;

with ADO.Schemas;
with ADO.Statements;
with ADO.Objects;
with ADO.Objects.Cache;
with ADO.Databases;
with ADO.Queries;
with ADO.SQL;

with Util.Concurrent.Counters;
limited with ADO.Sequences;
limited with ADO.Schemas.Entities;

package ADO.Sessions is

   use ADO.Statements;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   --  Raised if the database connection is not open.
   NOT_OPEN : exception;

   NOT_FOUND : exception;

   NO_DATABASE : exception;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   type Object_Factory is tagged private;

   --  ---------
   --  Session
   --  ---------
   --  Read-only database connection (or slave connection).
   --
   type Session is tagged private;

   --  Get the session status.
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status;

   --  Close the session.
   procedure Close (Database : in out Session);

   --  Get the database connection.
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class;

   --  Attach the object to the session.
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class);

   --  Check if the session contains the object identified by the given key.
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean;

   --  Remove the object from the session cache.
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key);

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement;

   --  Create a query statement and initialize the SQL statement with the query definition.
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  ---------
   --  Master Session
   --  ---------
   --  Read-write session.
   --
   type Master_Session is new Session with private;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Master_Session);

   --  Commit the current transaction.
   procedure Commit (Database : in out Master_Session);

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Master_Session);

   --  Allocate an identifier for the table.
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class);

   --  Flush the objects that were modified.
   procedure Flush (Database : in out Master_Session);

   --  Create a delete statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement;

   --  Create an update statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement;

   --  Create an insert statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement;

   type Session_Proxy is limited private;
   type Session_Proxy_Access is access all Session_Proxy;

   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access;

   type Session_Record is limited private;
   type Session_Record_Access is access all Session_Record;

private

   type Entity_Cache_Access is access constant ADO.Schemas.Entities.Entity_Cache;

   type Object_Factory is tagged record
      A : Integer;
   end record;
   type Object_Factory_Access is access all Object_Factory'Class;

   type Session_Proxy is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Session : Session_Record_Access;
      Factory : Object_Factory_Access;
   end record;

   --  The Session_Record maintains the connection information to the database for
   --  the duration of the session.  It also maintains a cache of application objects
   --  which is used when session objects are fetched (either through Load or a Find).
   --  The connection is released and the session record is deleted when the session
   --  is closed with Close.
   --
   --  For the lazy loading support, each object is associated with a shared Session_Proxy
   --  object that allows to give access to the session record associated with the object.
   --  When a session is closed, the Session_Proxy is not deleted but it is simply
   --  unlinked from the session record.
   type Session_Record is limited record
      Counter  : Natural := 1;
      Database : ADO.Databases.Master_Connection;
      Proxy    : ADO.Objects.Session_Proxy_Access;
      Cache    : ADO.Objects.Cache.Object_Cache;
      Entities : Entity_Cache_Access;
   end record;

   type Session is new Ada.Finalization.Controlled with record
      Impl : Session_Record_Access := null;
   end record;

   overriding
   procedure Adjust (Object : in out Session);

   overriding
   procedure Finalize (Object : in out Session);

   type Factory_Access is access all ADO.Sequences.Factory;

   type Master_Session is new Session with record
      Sequences : Factory_Access;
   end record;

   procedure Check_Session (Database : in Session'Class);
   pragma Inline (Check_Session);

end ADO.Sessions;

Change the Factory_Access to add 'all' access types


-----------------------------------------------------------------------
--  mat-targets-gtkmat - Gtk target management
--  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 Gtk.Widget;
with Gtkada.Builder;

with MAT.Events.Gtkmat;
with MAT.Consoles.Gtkmat;
package MAT.Targets.Gtkmat is

   type Target_Type is new MAT.Targets.Target_Type with private;
   type Target_Type_Access is access all Target_Type'Class;

   --  Initialize the target instance.
   overriding
   procedure Initialize (Target : in out Target_Type);

   --  Release the storage.
   overriding
   procedure Finalize (Target : in out Target_Type);

   --  Initialize the widgets and create the Gtk gui.
   procedure Initialize_Widget (Target : in out Target_Type;
                                Widget : out Gtk.Widget.Gtk_Widget);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   overriding
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   overriding
   procedure Interactive (Target : in out Target_Type);

   --  Set the UI label with the given value.
   procedure Set_Label (Target : in Target_Type;
                        Name   : in String;
                        Value  : in String);

   --  Refresh the information about the current process.
   procedure Refresh_Process (Target  : in out Target_Type);

private

   task type Gtk_Loop is
      entry Start (Target : in Target_Type_Access);
   end Gtk_Loop;

   type Target_Type is new MAT.Targets.Target_Type with record
      Builder     : Gtkada.Builder.Gtkada_Builder;
      Gui_Task    : Gtk_Loop;
      Previous_Event_Counter : Integer := 0;
      Gtk_Console : MAT.Consoles.Gtkmat.Console_Type_Access;
      Main        : Gtk.Widget.Gtk_Widget;
      About       : Gtk.Widget.Gtk_Widget;
      Chooser     : Gtk.Widget.Gtk_Widget;
      Events      : MAT.Events.Gtkmat.Event_Drawing_Type;
   end record;

   procedure Refresh_Events (Target : in out Target_Type);

end MAT.Targets.Gtkmat;

-----------------------------------------------------------------------
--  mat-targets-gtkmat - Gtk target management
--  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 Gtk.Widget;
with Gtkada.Builder;

with MAT.Events.Gtkmat;
with MAT.Consoles.Gtkmat;
package MAT.Targets.Gtkmat is

   type Target_Type is new MAT.Targets.Target_Type with private;
   type Target_Type_Access is access all Target_Type'Class;

   --  Initialize the target instance.
   overriding
   procedure Initialize (Target : in out Target_Type);

   --  Release the storage.
   overriding
   procedure Finalize (Target : in out Target_Type);

   --  Initialize the widgets and create the Gtk gui.
   procedure Initialize_Widget (Target : in out Target_Type;
                                Widget : out Gtk.Widget.Gtk_Widget);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   overriding
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   overriding
   procedure Interactive (Target : in out Target_Type);

   --  Set the UI label with the given value.
   procedure Set_Label (Target : in Target_Type;
                        Name   : in String;
                        Value  : in String);

   --  Refresh the information about the current process.
   procedure Refresh_Process (Target  : in out Target_Type);

private

   --  Load the glade XML definition.
   procedure Load_UI (Target : in out Target_Type);

   task type Gtk_Loop is
      entry Start (Target : in Target_Type_Access);
   end Gtk_Loop;

   type Target_Type is new MAT.Targets.Target_Type with record
      Builder     : Gtkada.Builder.Gtkada_Builder;
      Gui_Task    : Gtk_Loop;
      Previous_Event_Counter : Integer := 0;
      Gtk_Console : MAT.Consoles.Gtkmat.Console_Type_Access;
      Main        : Gtk.Widget.Gtk_Widget;
      About       : Gtk.Widget.Gtk_Widget;
      Chooser     : Gtk.Widget.Gtk_Widget;
      Events      : MAT.Events.Gtkmat.Event_Drawing_Type;
   end record;

   procedure Refresh_Events (Target : in out Target_Type);

end MAT.Targets.Gtkmat;

Declare the Load_UI procedure

Declare the Load_UI procedure


-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------
package body ASF.Utils is

   TITLE_ATTR         : aliased constant String := "title";
   STYLE_ATTR         : aliased constant String := "style";
   STYLE_CLASS_ATTR   : aliased constant String := "styleClass";
   DIR_ATTR           : aliased constant String := "dir";
   LANG_ATTR          : aliased constant String := "lang";

   ACCESS_KEY_ATTR    : aliased constant String := "accesskey";
   ON_BLUR_ATTR       : aliased constant String := "onblur";
   ON_CLICK_ATTR      : aliased constant String := "onclick";
   ON_DBLCLICK_ATTR   : aliased constant String := "ondblclick";
   ON_FOCUS_ATTR      : aliased constant String := "onfocus";
   ON_KEYDOWN_ATTR    : aliased constant String := "onkeydown";
   ON_KEYUP_ATTR      : aliased constant String := "onkeyup";
   ON_MOUSE_DOWN_ATTR : aliased constant String := "onmousedown";
   ON_MOUSE_MOVE_ATTR : aliased constant String := "onmousemove";
   ON_MOUSE_OUT_ATTR  : aliased constant String := "onmouseout";
   ON_MOUSE_OVER_ATTR : aliased constant String := "onmouseover";
   ON_MOUSE_UP_ATTR   : aliased constant String := "onmouseup";

   ON_RESET_ATTR      : aliased constant String := "onreset";
   ON_SUBMIT_ATTR     : aliased constant String := "onsubmit";
   ENCTYPE_ATTR       : aliased constant String := "enctype";

   ON_LOAD_ATTR       : aliased constant String := "onload";
   ON_UNLOAD_ATTR     : aliased constant String := "onunload";

   TABINDEX_ATTR      : aliased constant String := "tabindex";

   AUTOCOMPLETE_ATTR  : aliased constant String := "autocomplete";
   SIZE_ATTR          : aliased constant String := "size";
   MAXLENGTH_ATTR     : aliased constant String := "maxlength";
   ALT_ATTR           : aliased constant String := "alt";
   DISABLED_ATTR      : aliased constant String := "disabled";
   READONLY_ATTR      : aliased constant String := "readonly";

   ACCEPT_ATTR        : aliased constant String := "accept";

   ROWS_ATTR          : aliased constant String := "rows";
   COLS_ATTR          : aliased constant String := "cols";

   CHARSET_ATTR       : aliased constant String := "charset";
   SHAPE_ATTR         : aliased constant String := "shape";
   REV_ATTR           : aliased constant String := "rev";
   COORDS_ATTR        : aliased constant String := "coords";
   TARGET_ATTR        : aliased constant String := "target";
   HREFLANG_ATTR      : aliased constant String := "hreflang";

   --  ------------------------------
   --  Add in the names set, the basic text attributes that can be set
   --  on HTML elements (dir, lang, style, title).
   --  ------------------------------
   procedure Set_Text_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (STYLE_CLASS_ATTR'Access);
      Names.Insert (TITLE_ATTR'Access);
      Names.Insert (DIR_ATTR'Access);
      Names.Insert (LANG_ATTR'Access);
      Names.Insert (STYLE_ATTR'Access);
   end Set_Text_Attributes;

   --  ------------------------------
   --  Add in the names set, the onXXX attributes that can be set
   --  on HTML elements (accesskey, tabindex, onXXX).
   --  ------------------------------
   procedure Set_Interactive_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ACCESS_KEY_ATTR'Access);
      Names.Insert (TABINDEX_ATTR'Access);
      Names.Insert (ON_BLUR_ATTR'Access);
      Names.Insert (ON_MOUSE_UP_ATTR'Access);
      Names.Insert (ON_MOUSE_OVER_ATTR'Access);
      Names.Insert (ON_MOUSE_OUT_ATTR'Access);
      Names.Insert (ON_MOUSE_MOVE_ATTR'Access);
      Names.Insert (ON_MOUSE_DOWN_ATTR'Access);
      Names.Insert (ON_KEYUP_ATTR'Access);
      Names.Insert (ON_KEYDOWN_ATTR'Access);
      Names.Insert (ON_FOCUS_ATTR'Access);
      Names.Insert (ON_DBLCLICK_ATTR'Access);
      Names.Insert (ON_CLICK_ATTR'Access);
   end Set_Interactive_Attributes;

   --  ------------------------------
   --  Add in the names set, the size attributes that can be set
   --  on HTML elements.
   --  ------------------------------
   procedure Set_Input_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (SIZE_ATTR'Access);
      Names.Insert (AUTOCOMPLETE_ATTR'Access);
      Names.Insert (MAXLENGTH_ATTR'Access);
      Names.Insert (ALT_ATTR'Access);
      Names.Insert (DISABLED_ATTR'Access);
      Names.Insert (READONLY_ATTR'Access);
   end Set_Input_Attributes;

   --  ------------------------------
   --  Add in the names set, the size attributes that can be set
   --  on <textarea> elements.
   --  ------------------------------
   procedure Set_Textarea_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ROWS_ATTR'Access);
      Names.Insert (COLS_ATTR'Access);
   end Set_Textarea_Attributes;

   --  ------------------------------
   --  Add in the names set, the online and onunload attributes that can be set
   --  on  elements.
   --  ------------------------------
   procedure Set_Body_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ON_LOAD_ATTR'Access);
      Names.Insert (ON_UNLOAD_ATTR'Access);
   end Set_Body_Attributes;

   --  ------------------------------
   --  Add in the names set, the dir, lang attributes that can be set
   --  on  elements.
   --  ------------------------------
   procedure Set_Head_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (DIR_ATTR'Access);
      Names.Insert (LANG_ATTR'Access);
   end Set_Head_Attributes;

   --------------------
   --  Add in the names set, the onreset and onsubmit attributes that can be set
   --  on <form> elements.
   --  ------------------------------
   procedure Set_Form_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ON_RESET_ATTR'Access);
      Names.Insert (ON_SUBMIT_ATTR'Access);
      Names.Insert (ENCTYPE_ATTR'Access);
   end Set_Form_Attributes;

   --------------------
   --  Add in the names set, the attributes which are specific to a link.
   --  ------------------------------
   procedure Set_Link_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (CHARSET_ATTR'Access);
      Names.Insert (SHAPE_ATTR'Access);
      Names.Insert (REV_ATTR'Access);
      Names.Insert (COORDS_ATTR'Access);
      Names.Insert (TARGET_ATTR'Access);
      Names.Insert (HREFLANG_ATTR'Access);
   end Set_Link_Attributes;

   --  ------------------------------
   --  Add in the names set, the attributes which are specific to an input file.
   --  ------------------------------
   procedure Set_File_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ACCEPT_ATTR'Access);
   end Set_File_Attributes;

end ASF.Utils;

-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------
package body ASF.Utils is

   TITLE_ATTR         : aliased constant String := "title";
   STYLE_ATTR         : aliased constant String := "style";
   STYLE_CLASS_ATTR   : aliased constant String := "styleClass";
   DIR_ATTR           : aliased constant String := "dir";
   LANG_ATTR          : aliased constant String := "lang";

   ACCESS_KEY_ATTR    : aliased constant String := "accesskey";
   ON_BLUR_ATTR       : aliased constant String := "onblur";
   ON_CLICK_ATTR      : aliased constant String := "onclick";
   ON_DBLCLICK_ATTR   : aliased constant String := "ondblclick";
   ON_FOCUS_ATTR      : aliased constant String := "onfocus";
   ON_KEYDOWN_ATTR    : aliased constant String := "onkeydown";
   ON_KEYUP_ATTR      : aliased constant String := "onkeyup";
   ON_MOUSE_DOWN_ATTR : aliased constant String := "onmousedown";
   ON_MOUSE_MOVE_ATTR : aliased constant String := "onmousemove";
   ON_MOUSE_OUT_ATTR  : aliased constant String := "onmouseout";
   ON_MOUSE_OVER_ATTR : aliased constant String := "onmouseover";
   ON_MOUSE_UP_ATTR   : aliased constant String := "onmouseup";
   ON_CHANGE_ATTR     : aliased constant String := "onchange";

   ON_RESET_ATTR      : aliased constant String := "onreset";
   ON_SUBMIT_ATTR     : aliased constant String := "onsubmit";
   ENCTYPE_ATTR       : aliased constant String := "enctype";

   ON_LOAD_ATTR       : aliased constant String := "onload";
   ON_UNLOAD_ATTR     : aliased constant String := "onunload";

   TABINDEX_ATTR      : aliased constant String := "tabindex";

   AUTOCOMPLETE_ATTR  : aliased constant String := "autocomplete";
   SIZE_ATTR          : aliased constant String := "size";
   MAXLENGTH_ATTR     : aliased constant String := "maxlength";
   ALT_ATTR           : aliased constant String := "alt";
   DISABLED_ATTR      : aliased constant String := "disabled";
   READONLY_ATTR      : aliased constant String := "readonly";

   ACCEPT_ATTR        : aliased constant String := "accept";

   ROWS_ATTR          : aliased constant String := "rows";
   COLS_ATTR          : aliased constant String := "cols";

   CHARSET_ATTR       : aliased constant String := "charset";
   SHAPE_ATTR         : aliased constant String := "shape";
   REV_ATTR           : aliased constant String := "rev";
   COORDS_ATTR        : aliased constant String := "coords";
   TARGET_ATTR        : aliased constant String := "target";
   HREFLANG_ATTR      : aliased constant String := "hreflang";

   --  ------------------------------
   --  Add in the names set, the basic text attributes that can be set
   --  on HTML elements (dir, lang, style, title).
   --  ------------------------------
   procedure Set_Text_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (STYLE_CLASS_ATTR'Access);
      Names.Insert (TITLE_ATTR'Access);
      Names.Insert (DIR_ATTR'Access);
      Names.Insert (LANG_ATTR'Access);
      Names.Insert (STYLE_ATTR'Access);
   end Set_Text_Attributes;

   --  ------------------------------
   --  Add in the names set, the onXXX attributes that can be set
   --  on HTML elements (accesskey, tabindex, onXXX).
   --  ------------------------------
   procedure Set_Interactive_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ACCESS_KEY_ATTR'Access);
      Names.Insert (TABINDEX_ATTR'Access);
      Names.Insert (ON_BLUR_ATTR'Access);
      Names.Insert (ON_MOUSE_UP_ATTR'Access);
      Names.Insert (ON_MOUSE_OVER_ATTR'Access);
      Names.Insert (ON_MOUSE_OUT_ATTR'Access);
      Names.Insert (ON_MOUSE_MOVE_ATTR'Access);
      Names.Insert (ON_MOUSE_DOWN_ATTR'Access);
      Names.Insert (ON_KEYUP_ATTR'Access);
      Names.Insert (ON_KEYDOWN_ATTR'Access);
      Names.Insert (ON_FOCUS_ATTR'Access);
      Names.Insert (ON_DBLCLICK_ATTR'Access);
      Names.Insert (ON_CLICK_ATTR'Access);
      Names.Insert (ON_CHANGE_ATTR'Access);
   end Set_Interactive_Attributes;

   --  ------------------------------
   --  Add in the names set, the size attributes that can be set
   --  on HTML elements.
   --  ------------------------------
   procedure Set_Input_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (SIZE_ATTR'Access);
      Names.Insert (AUTOCOMPLETE_ATTR'Access);
      Names.Insert (MAXLENGTH_ATTR'Access);
      Names.Insert (ALT_ATTR'Access);
      Names.Insert (DISABLED_ATTR'Access);
      Names.Insert (READONLY_ATTR'Access);
   end Set_Input_Attributes;

   --  ------------------------------
   --  Add in the names set, the size attributes that can be set
   --  on <textarea> elements.
   --  ------------------------------
   procedure Set_Textarea_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ROWS_ATTR'Access);
      Names.Insert (COLS_ATTR'Access);
   end Set_Textarea_Attributes;

   --  ------------------------------
   --  Add in the names set, the online and onunload attributes that can be set
   --  on  elements.
   --  ------------------------------
   procedure Set_Body_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ON_LOAD_ATTR'Access);
      Names.Insert (ON_UNLOAD_ATTR'Access);
   end Set_Body_Attributes;

   --  ------------------------------
   --  Add in the names set, the dir, lang attributes that can be set
   --  on  elements.
   --  ------------------------------
   procedure Set_Head_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (DIR_ATTR'Access);
      Names.Insert (LANG_ATTR'Access);
   end Set_Head_Attributes;

   --------------------
   --  Add in the names set, the onreset and onsubmit attributes that can be set
   --  on <form> elements.
   --  ------------------------------
   procedure Set_Form_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ON_RESET_ATTR'Access);
      Names.Insert (ON_SUBMIT_ATTR'Access);
      Names.Insert (ENCTYPE_ATTR'Access);
   end Set_Form_Attributes;

   --------------------
   --  Add in the names set, the attributes which are specific to a link.
   --  ------------------------------
   procedure Set_Link_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (CHARSET_ATTR'Access);
      Names.Insert (SHAPE_ATTR'Access);
      Names.Insert (REV_ATTR'Access);
      Names.Insert (COORDS_ATTR'Access);
      Names.Insert (TARGET_ATTR'Access);
      Names.Insert (HREFLANG_ATTR'Access);
   end Set_Link_Attributes;

   --  ------------------------------
   --  Add in the names set, the attributes which are specific to an input file.
   --  ------------------------------
   procedure Set_File_Attributes (Names : in out Util.Strings.String_Set.Set) is
   begin
      Names.Insert (ACCEPT_ATTR'Access);
   end Set_File_Attributes;

end ASF.Utils;

Add the onchange attribute on input elements


-----------------------------------------------------------------------
--  gen-model-beans -- Ada Bean declarations
--  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.Strings.Unbounded;

with Util.Beans.Objects;

with Gen.Model.Tables;
package Gen.Model.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Bean Definition
   --  ------------------------------
   type Bean_Definition is new Tables.Table_Definition with null record;
   type Bean_Definition_Access is access all Bean_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Bean_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Bean_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Bean_Definition);

   --  Create an attribute with the given name and add it to the bean.
   procedure Add_Attribute (Bean   : in out Bean_Definition;
                            Name   : in Unbounded_String;
                            Column : out Gen.Model.Tables.Column_Definition_Access);

   --  Create a bean with the given name.
   function Create_Bean (Name : in Unbounded_String) return Bean_Definition_Access;

end Gen.Model.Beans;

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

with Ada.Strings.Unbounded;

with Util.Beans.Objects;

with Gen.Model.Tables;
package Gen.Model.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Bean Definition
   --  ------------------------------
   type Bean_Definition is new Tables.Table_Definition with null record;
   type Bean_Definition_Access is access all Bean_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Bean_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Bean_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Bean_Definition);

   --  Create an attribute with the given name and add it to the bean.
   procedure Add_Attribute (Bean   : in out Bean_Definition;
                            Name   : in Unbounded_String;
                            Column : out Gen.Model.Tables.Column_Definition_Access);

   --  Create a bean with the given name.
   function Create_Bean (Name : in Unbounded_String) return Bean_Definition_Access;

end Gen.Model.Beans;

Update copyright

Update copyright


-----------------------------------------------------------------------
--  gen-model-packages -- Packages holding model, query representation
--  Copyright (C) 2009, 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.Containers.Hashed_Maps;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;

with Gen.Model.List;
with Gen.Model.Mappings;
limited with Gen.Model.Enums;
limited with Gen.Model.Tables;
limited with Gen.Model.Queries;
limited with Gen.Model.Beans;
package Gen.Model.Packages is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Package Definition
   --  ------------------------------
   --  The Package_Definition holds the tables, queries and other information
   --  that must be generated for a given Ada package.
   type Package_Definition is new Definition with private;
   type Package_Definition_Access is access all Package_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   overriding
   procedure Prepare (O : in out Package_Definition);

   --  Initialize the package instance
   overriding
   procedure Initialize (O : in out Package_Definition);

   --  Find the type identified by the name.
   function Find_Type (From : in Package_Definition;
                       Name : in Unbounded_String)
                       return Gen.Model.Mappings.Mapping_Definition_Access;

   --  ------------------------------
   --  Model Definition
   --  ------------------------------
   --  The Model_Definition contains the complete model from one or
   --  several files.  It maintains a list of Ada packages that must be generated.
   type Model_Definition is new Definition with private;
   type Model_Definition_Access is access all Model_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Model_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Initialize the model definition instance.
   overriding
   procedure Initialize (O : in out Model_Definition);

   --  Returns True if the model contains at least one package.
   function Has_Packages (O : in Model_Definition) return Boolean;

   --  Register or find the package knowing its name
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access);

   --  Register the declaration of the given enum in the model.
   procedure Register_Enum (O    : in out Model_Definition;
                            Enum : access Gen.Model.Enums.Enum_Definition'Class);

   --  Register the declaration of the given table in the model.
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class);

   --  Register the declaration of the given query in the model.
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class);

   --  Register the declaration of the given bean in the model.
   procedure Register_Bean (O     : in out Model_Definition;
                            Bean  : access Gen.Model.Beans.Bean_Definition'Class);

   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String);

   --  Find the type identified by the name.
   function Find_Type (From : in Model_Definition;
                       Name : in Unbounded_String)
                       return Gen.Model.Mappings.Mapping_Definition_Access;

   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String);

   --  Get the directory name associated with the model.
   function Get_Dirname (O : in Model_Definition) return String;

   --  Get the directory name which contains the model.
   function Get_Model_Directory (O : in Model_Definition) return String;

   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   overriding
   procedure Prepare (O : in out Model_Definition);

   package Package_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Package_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Package_Cursor is Package_Map.Cursor;

   --  Get the first package of the model definition.
   function First (From : Model_Definition) return Package_Cursor;

   --  Returns true if the package cursor contains a valid package
   function Has_Element (Position : Package_Cursor) return Boolean
                         renames Package_Map.Has_Element;

   --  Returns the package definition.
   function Element (Position : Package_Cursor) return Package_Definition_Access
                     renames Package_Map.Element;

   --  Move the iterator to the next package definition.
   procedure Next (Position : in out Package_Cursor)
                   renames Package_Map.Next;

private

   package Table_List is new Gen.Model.List (T        => Definition,
                                             T_Access => Definition_Access);

   subtype Table_List_Definition is Table_List.List_Definition;
   subtype Enum_List_Definition is Table_List.List_Definition;

   type List_Object is new Util.Beans.Basic.List_Bean with record
      Values     : Util.Beans.Objects.Vectors.Vector;
      Row        : Natural;
      Value_Bean : Util.Beans.Objects.Object;
   end record;

   --  Get the number of elements in the list.
   overriding
   function Get_Count (From : in List_Object) return Natural;

   --  Set the current row index.  Valid row indexes start at 1.
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural);

   --  Get the element at the current row index.
   overriding
   function Get_Row (From  : in List_Object) return Util.Beans.Objects.Object;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object;

   type Package_Definition is new Definition with record
      --  Enums defined in the package.
      Enums        : aliased Enum_List_Definition;
      Enums_Bean   : Util.Beans.Objects.Object;

      --  Hibernate tables
      Tables       : aliased Table_List_Definition;
      Tables_Bean  : Util.Beans.Objects.Object;

      --  Custom queries
      Queries      : aliased Table_List_Definition;
      Queries_Bean : Util.Beans.Objects.Object;

      --  Ada Beans
      Beans        : aliased Table_List_Definition;
      Beans_Bean   : Util.Beans.Objects.Object;

      --  A list of external packages which are used (used for with clause generation).
      Used_Types   : aliased List_Object;
      Used         : Util.Beans.Objects.Object;

      --  A map of all types defined in this package.
      Types        : Gen.Model.Mappings.Mapping_Maps.Map;

      --  The package Ada name
      Pkg_Name     : Unbounded_String;

      --  The base name for the package (ex: gen-model-users)
      Base_Name    : Unbounded_String;

      --  True if the package uses Ada.Calendar.Time
      Uses_Calendar_Time : Boolean := False;

      --  The global model (used to resolve types from other packages).
      Model              : Model_Definition_Access;
   end record;

   type Model_Definition is new Definition with record
      --  List of all enums.
      Enums        : aliased Enum_List_Definition;
      Enums_Bean   : Util.Beans.Objects.Object;

      --  List of all tables.
      Tables       : aliased Table_List_Definition;
      Tables_Bean  : Util.Beans.Objects.Object;

      --  List of all queries.
      Queries      : aliased Table_List_Definition;
      Queries_Bean : Util.Beans.Objects.Object;

      --  Ada Beans
      Beans        : aliased Table_List_Definition;
      Beans_Bean   : Util.Beans.Objects.Object;

      --  Map of all packages.
      Packages     : Package_Map.Map;

      --  Directory associated with the model ('src', 'samples', 'regtests', ...).
      Dir_Name     : Unbounded_String;

      --  Directory that contains the SQL and model files.
      DB_Name      : Unbounded_String;
   end record;

end Gen.Model.Packages;

-----------------------------------------------------------------------
--  gen-model-packages -- Packages holding model, query representation
--  Copyright (C) 2009, 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.Containers.Hashed_Maps;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;

with Gen.Model.List;
with Gen.Model.Mappings;
limited with Gen.Model.Enums;
limited with Gen.Model.Tables;
limited with Gen.Model.Queries;
limited with Gen.Model.Beans;
package Gen.Model.Packages is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Model Definition
   --  ------------------------------
   --  The Model_Definition contains the complete model from one or
   --  several files.  It maintains a list of Ada packages that must be generated.
   type Model_Definition is new Definition with private;
   type Model_Definition_Access is access all Model_Definition'Class;

   --  ------------------------------
   --  Package Definition
   --  ------------------------------
   --  The Package_Definition holds the tables, queries and other information
   --  that must be generated for a given Ada package.
   type Package_Definition is new Definition with private;
   type Package_Definition_Access is access all Package_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   overriding
   procedure Prepare (O : in out Package_Definition);

   --  Initialize the package instance
   overriding
   procedure Initialize (O : in out Package_Definition);

   --  Find the type identified by the name.
   function Find_Type (From : in Package_Definition;
                       Name : in Unbounded_String)
                       return Gen.Model.Mappings.Mapping_Definition_Access;

   --  Get the model which contains all the package definitions.
   function Get_Model (From : in Package_Definition)
                       return Model_Definition_Access;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Model_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Initialize the model definition instance.
   overriding
   procedure Initialize (O : in out Model_Definition);

   --  Returns True if the model contains at least one package.
   function Has_Packages (O : in Model_Definition) return Boolean;

   --  Register or find the package knowing its name
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access);

   --  Register the declaration of the given enum in the model.
   procedure Register_Enum (O    : in out Model_Definition;
                            Enum : access Gen.Model.Enums.Enum_Definition'Class);

   --  Register the declaration of the given table in the model.
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class);

   --  Register the declaration of the given query in the model.
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class);

   --  Register the declaration of the given bean in the model.
   procedure Register_Bean (O     : in out Model_Definition;
                            Bean  : access Gen.Model.Beans.Bean_Definition'Class);

   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String);

   --  Find the type identified by the name.
   function Find_Type (From : in Model_Definition;
                       Name : in Unbounded_String)
                       return Gen.Model.Mappings.Mapping_Definition_Access;

   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String);

   --  Get the directory name associated with the model.
   function Get_Dirname (O : in Model_Definition) return String;

   --  Get the directory name which contains the model.
   function Get_Model_Directory (O : in Model_Definition) return String;

   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   overriding
   procedure Prepare (O : in out Model_Definition);

   package Package_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Package_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Package_Cursor is Package_Map.Cursor;

   --  Get the first package of the model definition.
   function First (From : Model_Definition) return Package_Cursor;

   --  Returns true if the package cursor contains a valid package
   function Has_Element (Position : Package_Cursor) return Boolean
                         renames Package_Map.Has_Element;

   --  Returns the package definition.
   function Element (Position : Package_Cursor) return Package_Definition_Access
                     renames Package_Map.Element;

   --  Move the iterator to the next package definition.
   procedure Next (Position : in out Package_Cursor)
                   renames Package_Map.Next;

private

   package Table_List is new Gen.Model.List (T        => Definition,
                                             T_Access => Definition_Access);

   subtype Table_List_Definition is Table_List.List_Definition;
   subtype Enum_List_Definition is Table_List.List_Definition;

   type List_Object is new Util.Beans.Basic.List_Bean with record
      Values     : Util.Beans.Objects.Vectors.Vector;
      Row        : Natural;
      Value_Bean : Util.Beans.Objects.Object;
   end record;

   --  Get the number of elements in the list.
   overriding
   function Get_Count (From : in List_Object) return Natural;

   --  Set the current row index.  Valid row indexes start at 1.
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural);

   --  Get the element at the current row index.
   overriding
   function Get_Row (From  : in List_Object) return Util.Beans.Objects.Object;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object;

   type Package_Definition is new Definition with record
      --  Enums defined in the package.
      Enums        : aliased Enum_List_Definition;
      Enums_Bean   : Util.Beans.Objects.Object;

      --  Hibernate tables
      Tables       : aliased Table_List_Definition;
      Tables_Bean  : Util.Beans.Objects.Object;

      --  Custom queries
      Queries      : aliased Table_List_Definition;
      Queries_Bean : Util.Beans.Objects.Object;

      --  Ada Beans
      Beans        : aliased Table_List_Definition;
      Beans_Bean   : Util.Beans.Objects.Object;

      --  A list of external packages which are used (used for with clause generation).
      Used_Types   : aliased List_Object;
      Used         : Util.Beans.Objects.Object;

      --  A map of all types defined in this package.
      Types        : Gen.Model.Mappings.Mapping_Maps.Map;

      --  The package Ada name
      Pkg_Name     : Unbounded_String;

      --  The base name for the package (ex: gen-model-users)
      Base_Name    : Unbounded_String;

      --  True if the package uses Ada.Calendar.Time
      Uses_Calendar_Time : Boolean := False;

      --  The global model (used to resolve types from other packages).
      Model              : Model_Definition_Access;
   end record;

   type Model_Definition is new Definition with record
      --  List of all enums.
      Enums        : aliased Enum_List_Definition;
      Enums_Bean   : Util.Beans.Objects.Object;

      --  List of all tables.
      Tables       : aliased Table_List_Definition;
      Tables_Bean  : Util.Beans.Objects.Object;

      --  List of all queries.
      Queries      : aliased Table_List_Definition;
      Queries_Bean : Util.Beans.Objects.Object;

      --  Ada Beans
      Beans        : aliased Table_List_Definition;
      Beans_Bean   : Util.Beans.Objects.Object;

      --  Map of all packages.
      Packages     : Package_Map.Map;

      --  Directory associated with the model ('src', 'samples', 'regtests', ...).
      Dir_Name     : Unbounded_String;

      --  Directory that contains the SQL and model files.
      DB_Name      : Unbounded_String;
   end record;

end Gen.Model.Packages;

Define new function Get_Model

Define new function Get_Model


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

package Util.Http.Headers is

   --  Some header names.
   Content_Type    : constant String := "Content-Type";
   Content_Length  : constant String := "Content-Length";
   Accept_Header   : constant String := "Accept";
   Accept_Language : constant String := "Accept-Language";
   Location        : constant String := "Location";
   Cookie          : constant String := "Cookie";
   Cache_Control   : constant String := "Cache-Control";

   function To_Header (Date : in Ada.Calendar.Time) return String
     renames Util.Dates.RFC7231.Image;

   type Quality_Type is digits 4 range 0.0 .. 1.0;

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

end Util.Http.Headers;

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

package Util.Http.Headers is

   --  Some header names.
   Content_Type    : constant String := "Content-Type";
   Content_Length  : constant String := "Content-Length";
   Accept_Header   : constant String := "Accept";
   Accept_Language : constant String := "Accept-Language";
   Location        : constant String := "Location";
   Cookie          : constant String := "Cookie";
   Cache_Control   : constant String := "Cache-Control";

   function To_Header (Date : in Ada.Calendar.Time) return String
     renames Util.Dates.RFC7231.Image;

   type Quality_Type is digits 4 range 0.0 .. 1.0;

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

end Util.Http.Headers;

Update missing with clause

Update missing with clause


------------------------------------------------------------------------------
-- Copyright (c) 2017-2019, 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;

package body Natools.Web.ACL.Sx_Backends is

   type User_Builder is record
      Tokens, Groups : Containers.Unsafe_Atom_Lists.List;
   end record;

   Cookie_Name : constant String := "User-Token";

   procedure Process_User
     (Builder : in out Token_Maps.Unsafe_Maps.Map;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Read_DB is new S_Expressions.Interpreter_Loop
     (Token_Maps.Unsafe_Maps.Map, Meaningless_Type, Process_User);

   procedure Read_User is new S_Expressions.Interpreter_Loop
     (User_Builder, Meaningless_Type, Process_User_Element);

   --------------------------
   -- Constructor Elements --
   --------------------------

   procedure Process_User
     (Builder : in out Token_Maps.Unsafe_Maps.Map;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      User : User_Builder;
      Identity : Containers.Identity;
   begin
      Read_User (Arguments, User, Meaningless_Value);

      Identity :=
        (User => S_Expressions.Atom_Ref_Constructors.Create (Name),
         Groups => Containers.Create (User.Groups));

      for Token of User.Tokens loop
         Builder.Include (Token, Identity);
      end loop;
   end Process_User;

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      S_Name : constant String := S_Expressions.To_String (Name);
   begin
      if S_Name = "tokens" or else S_Name = "token" then
         Containers.Append_Atoms (Builder.Tokens, Arguments);
      elsif S_Name = "groups" or else S_Name = "group" then
         Containers.Append_Atoms (Builder.Groups, Arguments);
      else
         Log (Severities.Error, "Unknown user element """ & S_Name & '"');
      end if;
   end Process_User_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   overriding procedure Authenticate
     (Self : in Backend;
      Exchange : in out Exchanges.Exchange)
   is
      Cursor : constant Token_Maps.Cursor
        := Self.Map.Find (S_Expressions.To_Atom
           (Exchange.Cookie (Cookie_Name)));
      Identity : Containers.Identity;
   begin
      if Token_Maps.Has_Element (Cursor) then
         Identity := Token_Maps.Element (Cursor);
      end if;

      Exchange.Set_Identity (Identity);
   end Authenticate;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return ACL.Backend'Class
   is
      Map : Token_Maps.Unsafe_Maps.Map;
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Open_List =>
            Read_DB (Arguments, Map, Meaningless_Value);

         when S_Expressions.Events.Add_Atom =>
            declare
               Reader : S_Expressions.File_Readers.S_Reader
                 := S_Expressions.File_Readers.Reader
                    (S_Expressions.To_String (Arguments.Current_Atom));
            begin
               Read_DB (Reader, Map, Meaningless_Value);
            end;

         when others =>
            Log (Severities.Error, "Unable to create ACL from S-expression"
              & " starting with " & Arguments.Current_Event'Img);
      end case;

      return Backend'(Map => Token_Maps.Create (Map));
   end Create;

   procedure Register
     (Id : in Character;
      Fn : in Hash_Function) is
   begin
      if Fn = null then
         null;
      elsif Hash_Function_DB.Is_Empty then
         Hash_Function_DB.Replace (new Hash_Function_Array'(Id => Fn));
      elsif Id in Hash_Function_DB.Query.Data.all'Range then
         Hash_Function_DB.Update.Data.all (Id) := Fn;
      else
         declare
            New_First : constant Hash_Id
              := Hash_Id'Min (Id, Hash_Function_DB.Query.Data.all'First);
            New_Last : constant Hash_Id
              := Hash_Id'Max (Id, Hash_Function_DB.Query.Data.all'Last);
            New_Data : constant Hash_Function_Array_Refs.Data_Access
              := new Hash_Function_Array'(New_First .. New_Last => null);
         begin
            New_Data (Hash_Function_DB.Query.Data.all'First
                  ..  Hash_Function_DB.Query.Data.all'Last)
              := Hash_Function_DB.Query.Data.all;
            Hash_Function_DB.Replace (New_Data);
         end;
      end if;
   end Register;

end Natools.Web.ACL.Sx_Backends;

------------------------------------------------------------------------------
-- Copyright (c) 2017-2019, 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;

package body Natools.Web.ACL.Sx_Backends is

   type User_Builder is record
      Tokens, Groups : Containers.Unsafe_Atom_Lists.List;
   end record;

   type Backend_Builder is record
      Map : Token_Maps.Unsafe_Maps.Map;
   end record;

   Cookie_Name : constant String := "User-Token";

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Read_DB is new S_Expressions.Interpreter_Loop
     (Backend_Builder, Meaningless_Type, Process_User);

   procedure Read_User is new S_Expressions.Interpreter_Loop
     (User_Builder, Meaningless_Type, Process_User_Element);

   --------------------------
   -- Constructor Elements --
   --------------------------

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      User : User_Builder;
      Identity : Containers.Identity;
   begin
      Read_User (Arguments, User, Meaningless_Value);

      Identity :=
        (User => S_Expressions.Atom_Ref_Constructors.Create (Name),
         Groups => Containers.Create (User.Groups));

      for Token of User.Tokens loop
         Builder.Map.Include (Token, Identity);
      end loop;
   end Process_User;

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      S_Name : constant String := S_Expressions.To_String (Name);
   begin
      if S_Name = "tokens" or else S_Name = "token" then
         Containers.Append_Atoms (Builder.Tokens, Arguments);
      elsif S_Name = "groups" or else S_Name = "group" then
         Containers.Append_Atoms (Builder.Groups, Arguments);
      else
         Log (Severities.Error, "Unknown user element """ & S_Name & '"');
      end if;
   end Process_User_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   overriding procedure Authenticate
     (Self : in Backend;
      Exchange : in out Exchanges.Exchange)
   is
      Cursor : constant Token_Maps.Cursor
        := Self.Map.Find (S_Expressions.To_Atom
           (Exchange.Cookie (Cookie_Name)));
      Identity : Containers.Identity;
   begin
      if Token_Maps.Has_Element (Cursor) then
         Identity := Token_Maps.Element (Cursor);
      end if;

      Exchange.Set_Identity (Identity);
   end Authenticate;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return ACL.Backend'Class
   is
      Builder : Backend_Builder;
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Open_List =>
            Read_DB (Arguments, Builder, Meaningless_Value);

         when S_Expressions.Events.Add_Atom =>
            declare
               Reader : S_Expressions.File_Readers.S_Reader
                 := S_Expressions.File_Readers.Reader
                    (S_Expressions.To_String (Arguments.Current_Atom));
            begin
               Read_DB (Reader, Builder, Meaningless_Value);
            end;

         when others =>
            Log (Severities.Error, "Unable to create ACL from S-expression"
              & " starting with " & Arguments.Current_Event'Img);
      end case;

      return Backend'(Map => Token_Maps.Create (Builder.Map));
   end Create;

   procedure Register
     (Id : in Character;
      Fn : in Hash_Function) is
   begin
      if Fn = null then
         null;
      elsif Hash_Function_DB.Is_Empty then
         Hash_Function_DB.Replace (new Hash_Function_Array'(Id => Fn));
      elsif Id in Hash_Function_DB.Query.Data.all'Range then
         Hash_Function_DB.Update.Data.all (Id) := Fn;
      else
         declare
            New_First : constant Hash_Id
              := Hash_Id'Min (Id, Hash_Function_DB.Query.Data.all'First);
            New_Last : constant Hash_Id
              := Hash_Id'Max (Id, Hash_Function_DB.Query.Data.all'Last);
            New_Data : constant Hash_Function_Array_Refs.Data_Access
              := new Hash_Function_Array'(New_First .. New_Last => null);
         begin
            New_Data (Hash_Function_DB.Query.Data.all'First
                  ..  Hash_Function_DB.Query.Data.all'Last)
              := Hash_Function_DB.Query.Data.all;
            Hash_Function_DB.Replace (New_Data);
         end;
      end if;
   end Register;

end Natools.Web.ACL.Sx_Backends;

acl-sx_backends: add a backend-builder type, to prepare for future complexity