-------------------------------------------------------------------------------
--   Copyright 2012 Julian Schutsch
--
--   This file is part of ParallelSim
--
--   ParallelSim is free software: you can redistribute it and/or modify
--   it under the terms of the GNU Affero General Public License as published
--   by the Free Software Foundation, either version 3 of the License, or
--   (at your option) any later version.
--
--   ParallelSim is distributed in the hope that it will be useful,
--   but WITHOUT ANY WARRANTY; without even the implied warranty of
--   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--   GNU Affero General Public License for more details.
--
--   You should have received a copy of the GNU Affero General Public License
--   along with ParallelSim.  If not, see <http://www.gnu.org/licenses/>.
-------------------------------------------------------------------------------

-- Revision History
--   18.Mar 2012 Julian Schutsch
--     - Original version

pragma Ada_2005;

with Interfaces;
with Interfaces.C;
with Interfaces.C.Strings;
with System;
with Ada.Unchecked_Conversion;

package Win32 is
   pragma Linker_Options ("-lgdi32");
   pragma Linker_Options ("-lopengl32");
   pragma Linker_Options ("-lglu32");

   type UINT_Type is new Interfaces.Unsigned_32;
   type DWORD_Type is new Interfaces.Unsigned_32;
   type HANDLE_Type is new System.Address;
   type HANDLE_Access is access HANDLE_Type;
   type UINT_PTR_Type is new Interfaces.C.ptrdiff_t;
   subtype LONG_PTR_Type is System.Address;
   type LONG_Type is new Interfaces.C.ptrdiff_t;
   subtype ULONG_PTR_Type is System.Address;
   subtype HWND_Type is HANDLE_Type;
   type WPARAM_Type is new Interfaces.C.ptrdiff_t;
   subtype LPARAM_Type is LONG_PTR_Type;
   subtype HINSTANCE_Type is HANDLE_Type;
   subtype HICON_Type is HANDLE_Type;
   subtype HCURSOR_Type is HICON_Type;
   subtype HBRUSH_Type is HANDLE_Type;
   subtype LPCTSTR_Type is Interfaces.C.Strings.chars_ptr;
   type WORD_Type is new Interfaces.Unsigned_16;
   type ATOM_Type is new WORD_Type;
   subtype HMENU_Type is HANDLE_TYPE;
   type LRESULT_Type is new LONG_Type;
   subtype HDC_Type is HANDLE_Type;
   type BOOL_Type is new Interfaces.C.int;
   type BYTE_Type is new Interfaces.Unsigned_8;
   subtype HGLRC_Type is HANDLE_Type;

   function HANDLEToInteger is new Ada.Unchecked_Conversion
     (Source => HANDLE_Type,
      Target => Interfaces.C.ptrdiff_t);

   NULLHANDLE : constant HANDLE_Type:=HANDLE_Type(System.Null_Address);
   TRUE       : constant BOOL_Type:=1;
   FALSE      : constant BOOL_Type:=0;

   function MAKEINTRESOURCE
     (wInteger : WORD_Type)
      return LPCTSTR_Type;
   function GET_X_LPARAM
     (lParam : LPARAM_Type)
      return Integer;
   function GET_Y_LPARAM
     (lParam : LPARAM_Type)
      return Integer;

   function LOWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   function HIWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   CS_HREDRAW : constant UINT_Type:=2;
   CS_VREDRAW : constant UINT_Type:=1;
   CS_OWNDC   : constant UINT_Type:=32;

   WS_OVERLAPPEDWINDOW : constant DWORD_Type:=16#cf0000#;
   WS_CLIPCHILDREN     : constant DWORD_Type:=16#2000000#;
   WS_CLIPSIBLINGS     : constant DWORD_Type:=16#4000000#;
   WS_EX_APPWINDOW     : constant DWORD_Type:=16#40000#;
   WS_EX_CLIENTEDGE    : constant DWORD_Type:=512;

   WM_MOUSELEAVE    : constant := 16#2A3#;
   WM_PAINT         : constant := 15;
   WM_CREATE        : constant := 1;
   WM_SIZE          : constant := 5;
   WM_SIZING        : constant := 532;
   WM_LBUTTONDBLCLK : constant := 515;
   WM_RBUTTONDBLCLK : constant := 518;
   WM_LBUTTONDOWN   : constant := 513;
   WM_LBUTTONUP     : constant := 514;
   WM_RBUTTONDOWN   : constant := 516;
   WM_RBUTTONUP     : constant := 517;
   WM_MOUSEMOVE     : constant := 512;
   WM_DESTROY       : constant := 2;
   WM_ERASEBKGND    : constant := 20;
   WM_KEYDOWN       : constant := 256;
   WM_KEYUP         : constant := 257;
   WM_CHAR          : constant := 258;
   WM_TIMER         : constant := 275;
   WM_QUIT          : constant := 18;

   SW_SHOW : constant := 5;

   PM_NOREMOVE : constant := 0;
   PM_REMOVE   : constant := 1;
   PM_NOYIELD  : constant := 2;

   PFD_DRAW_TO_WINDOW : constant:=4;
   PFD_SUPPORT_OPENGL : constant:=16#20#;
   PFD_TYPE_RGBA      : constant:=0;
   PFD_MAIN_PLANE     : constant:=0;

   IDI_WINLOGO     : constant:=32517;
   IDI_ASTERISK    : constant:=32516;
   IDI_APPLICATION : constant:=32512;
   IDI_ERROR       : constant:=32513;
   IDI_EXCLAMATION : constant:=32515;
   IDC_ARROW       : constant:=32512;

   SW_SHOWNOACTIVATE : constant:=8;

   STILL_ACTIVE : constant DWORD_Type:=259;

   type WNDPROC_Access is
     access function
       (hWnd    : HWND_Type;
        message : UINT_Type;
        wParam  : WPARAM_Type;
        lParam  : LPARAM_Type)
        return LRESULT_Type;
   pragma Convention(C,WNDPROC_Access);

   type WNDCLASS_Type is
      record
         style         : UINT_Type        := 0;
         lpfnWndProc   : WNDPROC_Access   := null;
         cbClsExtra    : Interfaces.C.int := 0;
         cbWndExtra    : Interfaces.C.int := 0;
         hInstance     : HINSTANCE_Type   := Win32.NULLHANDLE;
         hIcon         : HICON_Type       := Win32.NULLHANDLE;
         hCursor       : HCURSOR_Type     := Win32.NULLHANDLE;
         hbrBackground : HBRUSH_Type      := Win32.NULLHANDLE;
         lpszMenuName  : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
         lpszClassName : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
      end record;
   pragma Convention(C,WNDCLASS_Type);

   type CREATESTRUCT_Type is
      record
         lpCreateParams : System.Address:=System.Null_Address;
         hInstance      : HINSTANCE_Type:=Win32.NULLHANDLE;
         hMenu          : HMENU_Type:=Win32.NULLHANDLE;
         hwndParent     : HWND_Type:=Win32.NULLHANDLE;
         cy             : Interfaces.C.int:=0;
         cx             : Interfaces.C.int:=0;
         y              : Interfaces.C.int:=0;
         x              : Interfaces.C.int:=0;
         style          : LONG_Type:=0;
         lpszName       : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         lpszClass      : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         dwExStyle      : DWORD_Type:=0;
      end record;
   type CREATESTRUCT_Access is access CREATESTRUCT_Type;
   pragma Convention(C,CREATESTRUCT_Type);

   type POINT_Type is
      record
         x : LONG_Type;
         y : LONG_Type;
      end record;

   type MSG_Type is
      record
         hwnd    : HWND_Type;
         message : UINT_Type;
         wParam  : UINT_Type;
         lParam  : UINT_Type;
         time    : DWORD_Type;
         pt      : POINT_Type;
      end record;
   pragma Convention(C,MSG_Type);

   HANDLE_FLAG_INHERIT            : constant DWORD_Type:=1;
   HANDLE_FLAG_PROTECT_FROM_CLOSE : constant DWORD_Type:=2;

   type COMMTIMEOUTS_Type is
      record
         ReadIntervalTimeout         : DWORD_Type:=DWORD_Type'Last;
         ReadTotalTimeoutMultiplier  : DWORD_Type:=0;
         ReadTotalTimeoutConstant    : DWORD_Type:=0;
         WriteTotalTimeoutMultiplier : DWORD_Type:=0;
         WriteTotalTimeoutConstant   : DWORD_Type:=0;
      end record;
   pragma Convention(C,COMMTIMEOUTS_Type);

   type SECURITY_ATTRIBUTES_Type is
      record
         nLength              : DWORD_Type;
         lpSecurityDescriptor : System.Address:=System.Null_Address;
         bInheritHandle       : BOOL_Type;
      end record;
   pragma Convention(C,SECURITY_ATTRIBUTES_Type);
   type SECURITY_ATTRIBUTES_Access is access SECURITY_ATTRIBUTES_Type;

   type OVERLAPPED_Type is
      record
         Internal     : ULONG_PTR_Type := System.Null_Address;
         InternalHigh : ULONG_PTR_Type := System.Null_Address;
         Pointer      : System.Address := System.Null_Address;
         hEvent       : HANDLE_Type    := NULLHANDLE;
      end record;
   pragma Convention(C,OVERLAPPED_Type);

   type PIXELFORMATDESCRIPTOR_Type is
      record
         nSize           : WORD_Type  := 0;
         nVersion        : WORD_Type  := 0;
         dwFlags         : DWORD_Type := 0;
         iPixelType      : BYTE_Type  := 0;
         cColorBits      : BYTE_Type  := 0;
         cRedBits        : BYTE_Type  := 0;
         cRedShift       : BYTE_Type  := 0;
         cGreenBits      : BYTE_Type  := 0;
         cGreenShift     : BYTE_Type  := 0;
         cBlueBits       : BYTE_Type  := 0;
         cBlueShift      : BYTE_Type  := 0;
         cAlphaBits      : BYTE_Type  := 0;
         cAlphaShift     : BYTE_Type  := 0;
         cAccumBits      : BYTE_Type  := 0;
         cAccumRedBits   : BYTE_Type  := 0;
         cAccumGreenBits : BYTE_Type  := 0;
         cAccumBlueBits  : BYTE_Type  := 0;
         cAccumAlphaBits : BYTE_Type  := 0;
         cDepthBits      : BYTE_Type  := 0;
         cStencilBits    : BYTE_Type  := 0;
         cAuxBuffers     : BYTE_Type  := 0;
         iLayerType      : BYTE_Type  := 0;
         bReserved       : BYTE_Type  := 0;
         dwLayerMask     : DWORD_Type := 0;
         dwVisibleMask   : DWORD_Type := 0;
         dwDamageMask    : DWORD_Type := 0;
      end record;
   pragma Convention(C,PIXELFORMATDESCRIPTOR_Type);

   type STARTUPINFO_Type is
      record
         cb              : Interfaces.Unsigned_32;
         lpReserved      : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpDesktop       : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpTitle         : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         dwX             : Interfaces.Unsigned_32 := 0;
         dwY             : Interfaces.Unsigned_32 := 0;
         dwXSize         : Interfaces.Unsigned_32 := 0;
         dwYSize         : Interfaces.Unsigned_32 := 0;
         dwXCountChars   : Interfaces.Unsigned_32 := 0;
         dwYCountChars   : Interfaces.Unsigned_32 := 0;
         dwFillAttribute : Interfaces.Unsigned_32 := 0;
         dwFlags         : Interfaces.Unsigned_32 := 0;
         wShowWindow     : Interfaces.Unsigned_16 := 0;
         cbReserved2     : Interfaces.Unsigned_16 := 0;
         hStdInput       : HANDLE_Type            := NULLHANDLE;
         hStdOutput      : HANDLE_Type            := NULLHANDLE;
         hStderr         : HANDLE_Type            := NULLHANDLE;
      end record;
   pragma Convention(C,STARTUPINFO_Type);

   type PROCESS_INFORMATION_Type is
      record
         hProcess    : HANDLE_Type := NULLHANDLE;
         hThread     : HANDLE_Type := NULLHANDLE;
         dwProcessID : Interfaces.Unsigned_32 := 0;
         dwThreadID  : Interfaces.Unsigned_32 := 0;
      end record;
   pragma Convention(C,PROCESS_INFORMATION_Type);

   function GetLastError
     return DWORD_TYPE;
   pragma Import(StdCall,GetLastError,"GetLastError");

   STARTF_USESTDHANDLES : constant:=16#100#;

end Win32;

-------------------------------------------------------------------------------
--   Copyright 2012 Julian Schutsch
--
--   This file is part of ParallelSim
--
--   ParallelSim is free software: you can redistribute it and/or modify
--   it under the terms of the GNU Affero General Public License as published
--   by the Free Software Foundation, either version 3 of the License, or
--   (at your option) any later version.
--
--   ParallelSim is distributed in the hope that it will be useful,
--   but WITHOUT ANY WARRANTY; without even the implied warranty of
--   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--   GNU Affero General Public License for more details.
--
--   You should have received a copy of the GNU Affero General Public License
--   along with ParallelSim.  If not, see <http://www.gnu.org/licenses/>.
-------------------------------------------------------------------------------

-- Revision History
--   18.Mar 2012 Julian Schutsch
--     - Original version

pragma Ada_2005;

with Interfaces;
with Interfaces.C;
with Interfaces.C.Strings;
with System;
with Ada.Unchecked_Conversion;

package Win32 is

   type UINT_Type is new Interfaces.Unsigned_32;
   type DWORD_Type is new Interfaces.Unsigned_32;
   type HANDLE_Type is new System.Address;
   type HANDLE_Access is access HANDLE_Type;
   type UINT_PTR_Type is new Interfaces.C.ptrdiff_t;
   subtype LONG_PTR_Type is System.Address;
   type LONG_Type is new Interfaces.C.ptrdiff_t;
   subtype ULONG_PTR_Type is System.Address;
   subtype HWND_Type is HANDLE_Type;
   type WPARAM_Type is new Interfaces.C.ptrdiff_t;
   subtype LPARAM_Type is LONG_PTR_Type;
   subtype HINSTANCE_Type is HANDLE_Type;
   subtype HICON_Type is HANDLE_Type;
   subtype HCURSOR_Type is HICON_Type;
   subtype HBRUSH_Type is HANDLE_Type;
   subtype LPCTSTR_Type is Interfaces.C.Strings.chars_ptr;
   type WORD_Type is new Interfaces.Unsigned_16;
   type ATOM_Type is new WORD_Type;
   subtype HMENU_Type is HANDLE_TYPE;
   type LRESULT_Type is new LONG_Type;
   subtype HDC_Type is HANDLE_Type;
   type BOOL_Type is new Interfaces.C.int;
   type BYTE_Type is new Interfaces.Unsigned_8;
   subtype HGLRC_Type is HANDLE_Type;

   function HANDLEToInteger is new Ada.Unchecked_Conversion
     (Source => HANDLE_Type,
      Target => Interfaces.C.ptrdiff_t);

   NULLHANDLE : constant HANDLE_Type:=HANDLE_Type(System.Null_Address);
   TRUE       : constant BOOL_Type:=1;
   FALSE      : constant BOOL_Type:=0;

   function MAKEINTRESOURCE
     (wInteger : WORD_Type)
      return LPCTSTR_Type;
   function GET_X_LPARAM
     (lParam : LPARAM_Type)
      return Integer;
   function GET_Y_LPARAM
     (lParam : LPARAM_Type)
      return Integer;

   function LOWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   function HIWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   CS_HREDRAW : constant UINT_Type:=2;
   CS_VREDRAW : constant UINT_Type:=1;
   CS_OWNDC   : constant UINT_Type:=32;

   WS_OVERLAPPEDWINDOW : constant DWORD_Type:=16#cf0000#;
   WS_CLIPCHILDREN     : constant DWORD_Type:=16#2000000#;
   WS_CLIPSIBLINGS     : constant DWORD_Type:=16#4000000#;
   WS_EX_APPWINDOW     : constant DWORD_Type:=16#40000#;
   WS_EX_CLIENTEDGE    : constant DWORD_Type:=512;

   WM_MOUSELEAVE    : constant := 16#2A3#;
   WM_PAINT         : constant := 15;
   WM_CREATE        : constant := 1;
   WM_SIZE          : constant := 5;
   WM_SIZING        : constant := 532;
   WM_LBUTTONDBLCLK : constant := 515;
   WM_RBUTTONDBLCLK : constant := 518;
   WM_LBUTTONDOWN   : constant := 513;
   WM_LBUTTONUP     : constant := 514;
   WM_RBUTTONDOWN   : constant := 516;
   WM_RBUTTONUP     : constant := 517;
   WM_MOUSEMOVE     : constant := 512;
   WM_DESTROY       : constant := 2;
   WM_ERASEBKGND    : constant := 20;
   WM_KEYDOWN       : constant := 256;
   WM_KEYUP         : constant := 257;
   WM_CHAR          : constant := 258;
   WM_TIMER         : constant := 275;
   WM_QUIT          : constant := 18;

   SW_SHOW : constant := 5;

   PM_NOREMOVE : constant := 0;
   PM_REMOVE   : constant := 1;
   PM_NOYIELD  : constant := 2;

   PFD_DRAW_TO_WINDOW : constant:=4;
   PFD_SUPPORT_OPENGL : constant:=16#20#;
   PFD_TYPE_RGBA      : constant:=0;
   PFD_MAIN_PLANE     : constant:=0;

   IDI_WINLOGO     : constant:=32517;
   IDI_ASTERISK    : constant:=32516;
   IDI_APPLICATION : constant:=32512;
   IDI_ERROR       : constant:=32513;
   IDI_EXCLAMATION : constant:=32515;
   IDC_ARROW       : constant:=32512;

   SW_SHOWNOACTIVATE : constant:=8;

   STILL_ACTIVE : constant DWORD_Type:=259;

   type WNDPROC_Access is
     access function
       (hWnd    : HWND_Type;
        message : UINT_Type;
        wParam  : WPARAM_Type;
        lParam  : LPARAM_Type)
        return LRESULT_Type;
   pragma Convention(C,WNDPROC_Access);

   type WNDCLASS_Type is
      record
         style         : UINT_Type        := 0;
         lpfnWndProc   : WNDPROC_Access   := null;
         cbClsExtra    : Interfaces.C.int := 0;
         cbWndExtra    : Interfaces.C.int := 0;
         hInstance     : HINSTANCE_Type   := Win32.NULLHANDLE;
         hIcon         : HICON_Type       := Win32.NULLHANDLE;
         hCursor       : HCURSOR_Type     := Win32.NULLHANDLE;
         hbrBackground : HBRUSH_Type      := Win32.NULLHANDLE;
         lpszMenuName  : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
         lpszClassName : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
      end record;
   pragma Convention(C,WNDCLASS_Type);

   type CREATESTRUCT_Type is
      record
         lpCreateParams : System.Address:=System.Null_Address;
         hInstance      : HINSTANCE_Type:=Win32.NULLHANDLE;
         hMenu          : HMENU_Type:=Win32.NULLHANDLE;
         hwndParent     : HWND_Type:=Win32.NULLHANDLE;
         cy             : Interfaces.C.int:=0;
         cx             : Interfaces.C.int:=0;
         y              : Interfaces.C.int:=0;
         x              : Interfaces.C.int:=0;
         style          : LONG_Type:=0;
         lpszName       : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         lpszClass      : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         dwExStyle      : DWORD_Type:=0;
      end record;
   type CREATESTRUCT_Access is access CREATESTRUCT_Type;
   pragma Convention(C,CREATESTRUCT_Type);

   type POINT_Type is
      record
         x : LONG_Type;
         y : LONG_Type;
      end record;

   type MSG_Type is
      record
         hwnd    : HWND_Type;
         message : UINT_Type;
         wParam  : UINT_Type;
         lParam  : UINT_Type;
         time    : DWORD_Type;
         pt      : POINT_Type;
      end record;
   pragma Convention(C,MSG_Type);

   HANDLE_FLAG_INHERIT            : constant DWORD_Type:=1;
   HANDLE_FLAG_PROTECT_FROM_CLOSE : constant DWORD_Type:=2;

   type COMMTIMEOUTS_Type is
      record
         ReadIntervalTimeout         : DWORD_Type:=DWORD_Type'Last;
         ReadTotalTimeoutMultiplier  : DWORD_Type:=0;
         ReadTotalTimeoutConstant    : DWORD_Type:=0;
         WriteTotalTimeoutMultiplier : DWORD_Type:=0;
         WriteTotalTimeoutConstant   : DWORD_Type:=0;
      end record;
   pragma Convention(C,COMMTIMEOUTS_Type);

   type SECURITY_ATTRIBUTES_Type is
      record
         nLength              : DWORD_Type;
         lpSecurityDescriptor : System.Address:=System.Null_Address;
         bInheritHandle       : BOOL_Type;
      end record;
   pragma Convention(C,SECURITY_ATTRIBUTES_Type);
   type SECURITY_ATTRIBUTES_Access is access SECURITY_ATTRIBUTES_Type;

   type OVERLAPPED_Type is
      record
         Internal     : ULONG_PTR_Type := System.Null_Address;
         InternalHigh : ULONG_PTR_Type := System.Null_Address;
         Pointer      : System.Address := System.Null_Address;
         hEvent       : HANDLE_Type    := NULLHANDLE;
      end record;
   pragma Convention(C,OVERLAPPED_Type);

   type PIXELFORMATDESCRIPTOR_Type is
      record
         nSize           : WORD_Type  := 0;
         nVersion        : WORD_Type  := 0;
         dwFlags         : DWORD_Type := 0;
         iPixelType      : BYTE_Type  := 0;
         cColorBits      : BYTE_Type  := 0;
         cRedBits        : BYTE_Type  := 0;
         cRedShift       : BYTE_Type  := 0;
         cGreenBits      : BYTE_Type  := 0;
         cGreenShift     : BYTE_Type  := 0;
         cBlueBits       : BYTE_Type  := 0;
         cBlueShift      : BYTE_Type  := 0;
         cAlphaBits      : BYTE_Type  := 0;
         cAlphaShift     : BYTE_Type  := 0;
         cAccumBits      : BYTE_Type  := 0;
         cAccumRedBits   : BYTE_Type  := 0;
         cAccumGreenBits : BYTE_Type  := 0;
         cAccumBlueBits  : BYTE_Type  := 0;
         cAccumAlphaBits : BYTE_Type  := 0;
         cDepthBits      : BYTE_Type  := 0;
         cStencilBits    : BYTE_Type  := 0;
         cAuxBuffers     : BYTE_Type  := 0;
         iLayerType      : BYTE_Type  := 0;
         bReserved       : BYTE_Type  := 0;
         dwLayerMask     : DWORD_Type := 0;
         dwVisibleMask   : DWORD_Type := 0;
         dwDamageMask    : DWORD_Type := 0;
      end record;
   pragma Convention(C,PIXELFORMATDESCRIPTOR_Type);

   type STARTUPINFO_Type is
      record
         cb              : Interfaces.Unsigned_32;
         lpReserved      : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpDesktop       : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpTitle         : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         dwX             : Interfaces.Unsigned_32 := 0;
         dwY             : Interfaces.Unsigned_32 := 0;
         dwXSize         : Interfaces.Unsigned_32 := 0;
         dwYSize         : Interfaces.Unsigned_32 := 0;
         dwXCountChars   : Interfaces.Unsigned_32 := 0;
         dwYCountChars   : Interfaces.Unsigned_32 := 0;
         dwFillAttribute : Interfaces.Unsigned_32 := 0;
         dwFlags         : Interfaces.Unsigned_32 := 0;
         wShowWindow     : Interfaces.Unsigned_16 := 0;
         cbReserved2     : Interfaces.Unsigned_16 := 0;
         hStdInput       : HANDLE_Type            := NULLHANDLE;
         hStdOutput      : HANDLE_Type            := NULLHANDLE;
         hStderr         : HANDLE_Type            := NULLHANDLE;
      end record;
   pragma Convention(C,STARTUPINFO_Type);

   type PROCESS_INFORMATION_Type is
      record
         hProcess    : HANDLE_Type := NULLHANDLE;
         hThread     : HANDLE_Type := NULLHANDLE;
         dwProcessID : Interfaces.Unsigned_32 := 0;
         dwThreadID  : Interfaces.Unsigned_32 := 0;
      end record;
   pragma Convention(C,PROCESS_INFORMATION_Type);

   function GetLastError
     return DWORD_TYPE;
   pragma Import(StdCall,GetLastError,"GetLastError");

   STARTF_USESTDHANDLES : constant:=16#100#;

end Win32;

Revert "add linker_options pragmas for opengl/win"

This reverts commit 9d9a7ac0322c82a56675e0a87a8ea5215e554425.


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

   pragma Preelaborate;

   type Node_Kind is (N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_TOC_DISPLAY,
                      N_PARAGRAPH,
                      N_NEWLINE,
                      N_HEADER,
                      N_TOC,
                      N_TOC_ENTRY,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_PREFORMAT,
                      N_LIST,
                      N_NUM_LIST,
                      N_INDENT,
                      N_TEXT,
                      N_LINK,
                      N_IMAGE);

   --  Node kinds which are simple markers in the document.
   subtype Simple_Node_Kind is Node_Kind range N_LINE_BREAK .. N_NEWLINE;

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT | N_LIST | N_NUM_LIST | N_TOC_ENTRY =>
            Level  : Natural := 0;
            Header : Wiki.Strings.WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : Wiki.Strings.WString (1 .. Len);

         when N_LINK | N_IMAGE | N_QUOTE =>
            Link_Attr  : Wiki.Attributes.Attribute_List;
            Title      : Wiki.Strings.WString (1 .. Len);

         when N_TAG_START =>
            Tag_Start  : Html_Tag;
            Attributes : Wiki.Attributes.Attribute_List;
            Children   : Node_List_Access;
            Parent     : Node_Type_Access;

         when N_PREFORMAT =>
            Preformatted : Wiki.Strings.WString (1 .. Len);

         when N_TOC =>
            Entries    : Node_List_Access;

         when others =>
            null;

      end case;
   end record;

   --  Append a node to the tag node.
   procedure Append (Into : in Node_Type_Access;
                     Node : in Node_Type_Access);

   --  Append a node to the document.
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access);

   --  Finalize the node list to release the allocated memory.
   procedure Finalize (List : in out Node_List);

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 16;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block_Access;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : aliased Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

end Wiki.Nodes;

-----------------------------------------------------------------------
--  wiki-nodes -- Wiki Document Internal representation
--  Copyright (C) 2016, 2019, 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 Wiki.Attributes;
with Wiki.Strings;
package Wiki.Nodes is

   pragma Preelaborate;

   type Node_Kind is (N_LINE_BREAK,
                      N_HORIZONTAL_RULE,
                      N_TOC_DISPLAY,
                      N_PARAGRAPH,
                      N_NEWLINE,
                      N_HEADER,
                      N_TOC,
                      N_TOC_ENTRY,
                      N_BLOCKQUOTE,
                      N_QUOTE,
                      N_TAG_START,
                      N_PREFORMAT,
                      N_LIST,
                      N_NUM_LIST,
                      N_INDENT,
                      N_TEXT,
                      N_LINK,
                      N_IMAGE);

   --  Node kinds which are simple markers in the document.
   subtype Simple_Node_Kind is Node_Kind range N_LINE_BREAK .. N_NEWLINE;

   type Node_List is limited private;
   type Node_List_Access is access all Node_List;

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Node_Kind; Len : Natural) is limited record
      case Kind is
         when N_HEADER | N_BLOCKQUOTE | N_INDENT | N_LIST | N_NUM_LIST | N_TOC_ENTRY =>
            Level  : Natural := 0;
            Header : Wiki.Strings.WString (1 .. Len);

         when N_TEXT =>
            Format : Format_Map;
            Text   : Wiki.Strings.WString (1 .. Len);

         when N_LINK | N_IMAGE | N_QUOTE =>
            Link_Attr  : Wiki.Attributes.Attribute_List;
            Title      : Wiki.Strings.WString (1 .. Len);

         when N_TAG_START =>
            Tag_Start  : Html_Tag;
            Attributes : Wiki.Attributes.Attribute_List;
            Children   : Node_List_Access;
            Parent     : Node_Type_Access;

         when N_PREFORMAT =>
            Language     : Wiki.Strings.UString;
            Preformatted : Wiki.Strings.WString (1 .. Len);

         when N_TOC =>
            Entries    : Node_List_Access;

         when others =>
            null;

      end case;
   end record;

   --  Append a node to the tag node.
   procedure Append (Into : in Node_Type_Access;
                     Node : in Node_Type_Access);

   --  Append a node to the document.
   procedure Append (Into : in out Node_List;
                     Node : in Node_Type_Access);

   --  Finalize the node list to release the allocated memory.
   procedure Finalize (List : in out Node_List);

private

   NODE_LIST_BLOCK_SIZE : constant Positive := 16;

   type Node_Array is array (Positive range <>) of Node_Type_Access;

   type Node_List_Block;
   type Node_List_Block_Access is access all Node_List_Block;

   type Node_List_Block (Max : Positive) is limited record
      Next  : Node_List_Block_Access;
      Last  : Natural := 0;
      List  : Node_Array (1 .. Max);
   end record;

   type Node_List is limited record
      Current : Node_List_Block_Access;
      Length  : Natural := 0;
      First   : aliased Node_List_Block (NODE_LIST_BLOCK_SIZE);
   end record;

end Wiki.Nodes;

Add Language record member for the pre-formatted node


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

with Util.Tests;
package Util.Dates.Formats.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Format (T : in out Test);

   --  Test the Get_Day_Start operation.
   procedure Test_Get_Day_Start (T : in out Test);

   --  Test the Get_Week_Start operation.
   procedure Test_Get_Week_Start (T : in out Test);

   --  Test the Get_Month_Start operation.
   procedure Test_Get_Month_Start (T : in out Test);

   --  Test the Get_Day_End operation.
   procedure Test_Get_Day_End (T : in out Test);

   --  Test the Get_Week_End operation.
   procedure Test_Get_Week_End (T : in out Test);

   --  Test the Get_Month_End operation.
   procedure Test_Get_Month_End (T : in out Test);

   --  Test the Split operation.
   procedure Test_Split (T : in out Test);

   --  Test the Append_Date operation
   procedure Test_Append_Date (T : in out Test);

end Util.Dates.Formats.Tests;

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

with Util.Tests;
package Util.Dates.Formats.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Format (T : in out Test);

   --  Test the Get_Day_Start operation.
   procedure Test_Get_Day_Start (T : in out Test);

   --  Test the Get_Week_Start operation.
   procedure Test_Get_Week_Start (T : in out Test);

   --  Test the Get_Month_Start operation.
   procedure Test_Get_Month_Start (T : in out Test);

   --  Test the Get_Day_End operation.
   procedure Test_Get_Day_End (T : in out Test);

   --  Test the Get_Week_End operation.
   procedure Test_Get_Week_End (T : in out Test);

   --  Test the Get_Month_End operation.
   procedure Test_Get_Month_End (T : in out Test);

   --  Test the Split operation.
   procedure Test_Split (T : in out Test);

   --  Test the Append_Date operation
   procedure Test_Append_Date (T : in out Test);

   --  Test the ISO8601 operations.
   procedure Test_ISO8601 (T : in out Test);

end Util.Dates.Formats.Tests;

Declare Test_ISO8601 procedure

Declare Test_ISO8601 procedure


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

with Util.Strings.Maps;
with Util.Tests;
package Security.Random.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Generate (T : in out Test);

end Security.Random.Tests;

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

with Util.Tests;
package Security.Random.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Generate (T : in out Test);

end Security.Random.Tests;

Remove unused with clause

Remove unused with clause


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

package body Babel.Base.Users.Tests is

   use type Util.Strings.Name_Access;

   package Caller is new Util.Test_Caller (Test, "Base.Users");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Base.Users.Find",
                       Test_Find'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Find (T : in out Test) is
      Db   : Babel.Base.Users.Database;
      User : User_Type;
   begin
      User := Db.Find (0, 0);
      T.Assert (User.Name /= null, "User uid=0 was not found");
      T.Assert (User.Group /= null, "User gid=0 was not found");
      Util.Tests.Assert_Equals (T, "root", User.Name.all, "Invalid root user name");
      Util.Tests.Assert_Equals (T, "root", User.Group.all, "Invalid root group name");
   end Test_Find;

end Babel.Base.Users.Tests;

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

package body Babel.Base.Users.Tests is

   use type Util.Strings.Name_Access;

   package Caller is new Util.Test_Caller (Test, "Base.Users");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Base.Users.Find",
                       Test_Find'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Find (T : in out Test) is
      Db   : Babel.Base.Users.Database;
      User : User_Type;
   begin
      User := Db.Find (0, 0);
      T.Assert (User.Name /= null, "User uid=0 was not found");
      T.Assert (User.Group /= null, "User gid=0 was not found");
      Util.Tests.Assert_Equals (T, "root", User.Name.all, "Invalid root user name");
      Util.Tests.Assert_Equals (T, "root", User.Group.all, "Invalid root group name");

      User := Db.Find ("bin", "daemon");
      T.Assert (User.Name /= null, "User bin was not found");
      T.Assert (User.Group /= null, "Group daemon was not found");
      Util.Tests.Assert_Equals (T, "bin", User.Name.all, "Invalid 'bin' user name");
      Util.Tests.Assert_Equals (T, "daemon", User.Group.all, "Invalid 'daemon' group name");
      T.Assert (User.Uid > 0, "Invalid 'bin' uid");
      T.Assert (User.Gid > 0, "Invalid 'daemon' gid");
   end Test_Find;

end Babel.Base.Users.Tests;

Add more test case for the Find operation


-----------------------------------------------------------------------
--  components-utils-escape -- Escape generated content produced by component children
--  Copyright (C) 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 ASF.Components.Core;
with ASF.Contexts.Faces;
with ASF.Contexts.Writer;

package ASF.Components.Utils.Escapes is

   --  ------------------------------
   --  UIEscape
   --  ------------------------------
   --  The <b>UIEscape</b> component catches the rendering of child components to
   --  perform specific escape actions on the content.
   type UIEscape is new ASF.Components.Core.UIComponentBase with private;

   --  Write the content that was collected by rendering the inner children.
   --  Escape the content using Javascript escape rules.
   procedure Write_Content (UI      : in UIEscape;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Encode the children components in a local buffer.
   overriding
   procedure Encode_Children (UI      : in UIEscape;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

private

   type UIEscape is new ASF.Components.Core.UIComponentBase with null record;

end ASF.Components.Utils.Escapes;

-----------------------------------------------------------------------
--  components-utils-escape -- Escape generated content produced by component children
--  Copyright (C) 2011, 2012, 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 ASF.Components.Core;
with ASF.Contexts.Faces;
with ASF.Contexts.Writer;

package ASF.Components.Utils.Escapes is

   --  Name of the attribute that control the escape mode.
   --  When the attribute is set to 'xml', the content is escaped using XML
   --  escape rules.  Otherwise, the content is escaped using Javascript rules.
   ESCAPE_MODE_NAME : constant String := "mode";

   --  ------------------------------
   --  UIEscape
   --  ------------------------------
   --  The <b>UIEscape</b> component catches the rendering of child components to
   --  perform specific escape actions on the content.
   type UIEscape is new ASF.Components.Core.UIComponentBase with private;

   --  Write the content that was collected by rendering the inner children.
   --  Escape the content using Javascript escape rules.
   procedure Write_Content (UI      : in UIEscape;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Encode the children components in a local buffer.
   overriding
   procedure Encode_Children (UI      : in UIEscape;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

private

   type UIEscape is new ASF.Components.Core.UIComponentBase with null record;

end ASF.Components.Utils.Escapes;

Define ESCAPE_MODE_NAME to allow escaping using XML or Javascript rules


-----------------------------------------------------------------------
--  Print_User -- Example to find an object from the database
--  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 ADO;
with ADO.Drivers;
with ADO.Sessions;
with ADO.SQL;
with ADO.Sessions.Factory;
with Samples.User.Model;
with Util.Log.Loggers;
with Ada.Text_IO;

with Ada.Command_Line;
procedure Print_User is

   use ADO;
   use Ada;
   use Samples.User.Model;

   Factory : ADO.Sessions.Factory.Session_Factory;
   User    : User_Ref;

begin
   Util.Log.Loggers.Initialize ("log4j.properties");

   if Ada.Command_Line.Argument_Count < 2 then
      Ada.Text_IO.Put_Line ("Usage: print_user connection user-name ...");
      Ada.Text_IO.Put_Line ("Example: print_user 'mysql://localhost:3306/ado_test?user=root' joe");
      Ada.Command_Line.Set_Exit_Status (2);
      return;
   end if;

   --  Initialize the database drivers.
   ADO.Drivers.Initialize;

   --  Create and configure the connection pool
   Factory.Create (Ada.Command_Line.Argument (1));

   declare
      Session : ADO.Sessions.Session := Factory.Get_Session;
      Found   : Boolean;
   begin
      for I in 2 .. Ada.Command_Line.Argument_Count loop
         declare
            User_Name : constant String := Ada.Command_Line.Argument (I);
            Query     : ADO.SQL.Query;
         begin
            Ada.Text_IO.Put_Line ("Searching '" & User_Name & "'...");
            Query.Bind_Param (1, User_Name);
            Query.Set_Filter ("name = ?");
            User.Find (Session => Session, Query => Query, Found => Found);
            if Found then
               Ada.Text_IO.Put_Line ("  Id     :  " & Identifier'Image (User.Get_Id));
               Ada.Text_IO.Put_Line ("  User   :  " & User.Get_Name);
               Ada.Text_IO.Put_Line ("  Email  :  " & User.Get_Email);
            else
               Ada.Text_IO.Put_Line ("  User '" & User_Name & "' does not exist");
            end if;
         end;
      end loop;
   end;
end Print_User;

-----------------------------------------------------------------------
--  Print_User -- Example to find an object from the database
--  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 ADO;
with ADO.Drivers;
with ADO.Sessions;
with ADO.SQL;
with ADO.Sessions.Factory;
with Samples.User.Model;
with Util.Log.Loggers;
with Ada.Text_IO;

with Ada.Command_Line;
procedure Print_User is

   use ADO;
   use Ada;
   use Samples.User.Model;

   Factory : ADO.Sessions.Factory.Session_Factory;
begin
   Util.Log.Loggers.Initialize ("samples.properties");

   --  Initialize the database drivers.
   ADO.Drivers.Initialize ("samples.properties");

   if Ada.Command_Line.Argument_Count < 1 then
      Ada.Text_IO.Put_Line ("Usage: print_user user-name ...");
      Ada.Text_IO.Put_Line ("Example: print_user joe");
      Ada.Command_Line.Set_Exit_Status (2);
      return;
   end if;

   --  Create and configure the connection pool
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      Session : ADO.Sessions.Session := Factory.Get_Session;
      User    : User_Ref;
      Found   : Boolean;
   begin
      for I in 1 .. Ada.Command_Line.Argument_Count loop
         declare
            User_Name : constant String := Ada.Command_Line.Argument (I);
            Query     : ADO.SQL.Query;
         begin
            Ada.Text_IO.Put_Line ("Searching '" & User_Name & "'...");
            Query.Bind_Param (1, User_Name);
            Query.Set_Filter ("name = ?");
            User.Find (Session => Session, Query => Query, Found => Found);
            if Found then
               Ada.Text_IO.Put_Line ("  Id     :  " & Identifier'Image (User.Get_Id));
               Ada.Text_IO.Put_Line ("  User   :  " & User.Get_Name);
               Ada.Text_IO.Put_Line ("  Email  :  " & User.Get_Email);
            else
               Ada.Text_IO.Put_Line ("  User '" & User_Name & "' does not exist");
            end if;
         end;
      end loop;
   end;
end Print_User;

Update the print example

Update the print example


with AdaBase.Results.Field;
with Ada.Strings.Unbounded;
with Ada.Integer_Text_IO;
with Ada.Text_IO;
with Ada.Wide_Text_IO;

procedure Spawn_Fields is
   package TIO renames Ada.Text_IO;
   package WIO renames Ada.Wide_Text_IO;
   package IIO renames Ada.Integer_Text_IO;
   package SU  renames Ada.Strings.Unbounded;
   package ARC renames AdaBase.Results;

   FA : ARC.Field.field_access :=
        ARC.Field.spawn_field (binob => (50, 15, 4, 8));

   BR : ARC.Field.field_access :=
        ARC.Field.spawn_field (data =>
        (datatype => AdaBase.ft_textual,
              v13 => SU.To_Unbounded_String ("Baltimore Ravens")));

   myset : ARC.settype (1 .. 3) :=
               ((enumeration => SU.To_Unbounded_String ("hockey")),
                (enumeration => SU.To_Unbounded_String ("baseball")),
                (enumeration => SU.To_Unbounded_String ("tennis")));

   ST : ARC.Field.field_access := ARC.Field.spawn_field (enumset => myset);

   chain_len : Natural := FA.as_chain'Length;

begin
   TIO.Put_Line ("Chain #1 length:" & chain_len'Img);
   TIO.Put_Line ("Chain #1   type: " & FA.native_type'Img);
   for x in 1 .. chain_len loop
      TIO.Put ("  block" & x'Img & " value:" & FA.as_chain (x)'Img);
      IIO.Put (Item => Natural (FA.as_chain (x)), Base => 16);
      TIO.Put_Line ("");
   end loop;
   TIO.Put ("Chain #1 converted to 4-byte unsigned integer:" &
             FA.as_nbyte4'Img & "  ");
   IIO.Put (Item => Natural (FA.as_nbyte4), Base => 16);
   TIO.Put_Line ("");
   TIO.Put_Line ("");

   WIO.Put_Line ("Convert BR field to wide string: " & BR.as_wstring);
   TIO.Put_Line ("Convert ST settype to string:    " & ST.as_string);
   TIO.Put_Line ("Length of ST set:               " & myset'Length'Img);
end Spawn_Fields;

with AdaBase.Results.Field;
with AdaBase.Results.Converters;
with Ada.Strings.Unbounded;
with Ada.Integer_Text_IO;
with Ada.Text_IO;
with Ada.Wide_Text_IO;

procedure Spawn_Fields is
   package TIO renames Ada.Text_IO;
   package WIO renames Ada.Wide_Text_IO;
   package IIO renames Ada.Integer_Text_IO;
   package SU  renames Ada.Strings.Unbounded;
   package AR  renames AdaBase.Results;
   package ARC renames AdaBase.Results.Converters;

   SF : AR.Field.std_field :=
        AR.Field.spawn_field (binob => (50, 15, 4, 8));

   BR : AR.Field.std_field :=
        AR.Field.spawn_field (data =>
        (datatype => AdaBase.ft_textual,
              v13 => SU.To_Unbounded_String ("Baltimore Ravens")));

   myset : AR.settype (1 .. 3) :=
               ((enumeration => SU.To_Unbounded_String ("hockey")),
                (enumeration => SU.To_Unbounded_String ("baseball")),
                (enumeration => SU.To_Unbounded_String ("tennis")));

   ST : AR.Field.std_field :=
        AR.Field.spawn_field (enumset => ARC.convert (myset));

   chain_len : Natural := SF.as_chain'Length;

begin
   TIO.Put_Line ("Chain #1 length:" & chain_len'Img);
   TIO.Put_Line ("Chain #1   type: " & SF.native_type'Img);
   for x in 1 .. chain_len loop
      TIO.Put ("  block" & x'Img & " value:" & SF.as_chain (x)'Img);
      IIO.Put (Item => Natural (SF.as_chain (x)), Base => 16);
      TIO.Put_Line ("");
   end loop;
   TIO.Put ("Chain #1 converted to 4-byte unsigned integer:" &
             SF.as_nbyte4'Img & "  ");
   IIO.Put (Item => Natural (SF.as_nbyte4), Base => 16);
   TIO.Put_Line ("");
   TIO.Put_Line ("");

   WIO.Put_Line ("Convert BR field to wide string: " & BR.as_wstring);
   TIO.Put_Line ("Convert ST settype to string:    " & ST.as_string);
   TIO.Put_Line ("Length of ST set:               " & myset'Length'Img);
end Spawn_Fields;

Adjust spawn fields test case after recent change


-----------------------------------------------------------------------
--  gen-model-list -- List bean interface for model objects
--  Copyright (C) 2009, 2010, 2011, 2012, 2018 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 Gen.Model.List is

   --  ------------------------------
   --  Make an iterator for the list.
   --  ------------------------------
   function Iterate (Container : in List_Definition)
                     return List_Iterator.Forward_Iterator'Class is
   begin
      return Result : constant Iterator := (List => Container.Self);
   end Iterate;

   --  ------------------------------
   --  Make an iterator for the list.
   --  ------------------------------
   function Element_Value (Container : in List_Definition;
                           Pos       : in Cursor)
                           return T_Access is
      pragma Unreferenced (Container);
   begin
      return Element (Pos);
   end Element_Value;

   overriding
   function First (Object : in Iterator) return Cursor is
   begin
      return Object.List.First;
   end First;

   overriding
   function Next (Object : in Iterator;
                  Pos    : in Cursor) return Cursor is
      pragma Unreferenced (Object);

      C : Cursor := Pos;
   begin
      Next (C);
      return C;
   end Next;

   --  ------------------------------
   --  Compare the two definitions.
   --  ------------------------------
   function "<" (Left, Right : in T_Access) return Boolean is
      Left_Name  : constant String := Left.Get_Name;
      Right_Name : constant String := Right.Get_Name;
   begin
      return Left_Name < Right_Name;
   end "<";

   --  ------------------------------
   --  Get the first item of the list
   --  ------------------------------
   function First (Def : List_Definition) return Cursor is
   begin
      return Def.Nodes.First;
   end First;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Definition) return Natural is
      Count : constant Natural := Natural (From.Nodes.Length);
   begin
      return Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Definition;
                            Index : in Natural) is
   begin
      From.Row := Index;
      if Index > 0 then
         declare
            Current : constant T_Access := From.Nodes.Element (Index - 1);
            Bean    : constant Util.Beans.Basic.Readonly_Bean_Access := Current.all'Access;
         begin
            Current.Row_Index := Index;
            From.Value_Bean := Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;
      else
         From.Value_Bean := Util.Beans.Objects.Null_Object;
      end if;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Definition) return Util.Beans.Objects.Object is
   begin
      return From.Value_Bean;
   end Get_Row;

   --  ------------------------------
   --  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 : List_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "size" then
         return Util.Beans.Objects.To_Object (From.Get_Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Append the item in the list
   --  ------------------------------
   procedure Append (Def  : in out List_Definition;
                     Item : in T_Access) is
   begin
      Def.Nodes.Append (Item);
   end Append;

   --  ------------------------------
   --  Sort the list of items on their names.
   --  ------------------------------
   procedure Sort (List : in out List_Definition) is
   begin
      Sorting.Sort (List.Nodes);
   end Sort;

   procedure Sort_On (List : in out List_Definition) is
      package Sorting is new Vectors.Generic_Sorting;
   begin
      Sorting.Sort (List.Nodes);
   end Sort_On;

   --  ------------------------------
   --  Find a definition given the name.
   --  Returns the definition object or null.
   --  ------------------------------
   function Find (Def  : in List_Definition;
                  Name : in String) return T_Access is
      Iter : Vectors.Cursor := Def.Nodes.First;
   begin
      while Vectors.Has_Element (Iter) loop
         if Vectors.Element (Iter).Get_Name = Name then
            return Vectors.Element (Iter);
         end if;
         Vectors.Next (Iter);
      end loop;
      return null;
   end Find;

   --  ------------------------------
   --  Iterate over the elements of the list executing the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterate (Def     : in List_Definition;
                      Process : not null access procedure (Item : in T_Access)) is
      Iter : Vectors.Cursor := Def.Nodes.First;
   begin
      while Vectors.Has_Element (Iter) loop
         Process (Vectors.Element (Iter));
         Vectors.Next (Iter);
      end loop;
   end Iterate;

end Gen.Model.List;

-----------------------------------------------------------------------
--  gen-model-list -- List bean interface for model objects
--  Copyright (C) 2009, 2010, 2011, 2012, 2018 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 Gen.Model.List is

   --  ------------------------------
   --  Make an iterator for the list.
   --  ------------------------------
   function Iterate (Container : in List_Definition)
                     return List_Iterator.Forward_Iterator'Class is
   begin
      return Result : constant Iterator := (List => Container.Self);
   end Iterate;

   --  ------------------------------
   --  Make an iterator for the list.
   --  ------------------------------
   function Element_Value (Container : in List_Definition;
                           Pos       : in Cursor)
                           return T_Access is
      pragma Unreferenced (Container);
   begin
      return Element (Pos);
   end Element_Value;

   overriding
   function First (Object : in Iterator) return Cursor is
   begin
      return Object.List.First;
   end First;

   overriding
   function Next (Object : in Iterator;
                  Pos    : in Cursor) return Cursor is
      pragma Unreferenced (Object);

      C : Cursor := Pos;
   begin
      Next (C);
      return C;
   end Next;

   --  ------------------------------
   --  Compare the two definitions.
   --  ------------------------------
   function "<" (Left, Right : in T_Access) return Boolean is
      Left_Name  : constant String := Left.Get_Name;
      Right_Name : constant String := Right.Get_Name;
   begin
      return Left_Name < Right_Name;
   end "<";

   --  ------------------------------
   --  Get the first item of the list
   --  ------------------------------
   function First (Def : List_Definition) return Cursor is
   begin
      return Def.Nodes.First;
   end First;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Definition) return Natural is
      Count : constant Natural := Natural (From.Nodes.Length);
   begin
      return Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Definition;
                            Index : in Natural) is
   begin
      From.Row := Index;
      if Index > 0 then
         declare
            Current : constant T_Access := From.Nodes.Element (Index - 1);
            Bean    : constant Util.Beans.Basic.Readonly_Bean_Access := Current.all'Access;
         begin
            Current.Set_Index (Index);
            From.Value_Bean := Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
         end;
      else
         From.Value_Bean := Util.Beans.Objects.Null_Object;
      end if;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Definition) return Util.Beans.Objects.Object is
   begin
      return From.Value_Bean;
   end Get_Row;

   --  ------------------------------
   --  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 : List_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "size" then
         return Util.Beans.Objects.To_Object (From.Get_Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Append the item in the list
   --  ------------------------------
   procedure Append (Def  : in out List_Definition;
                     Item : in T_Access) is
   begin
      Def.Nodes.Append (Item);
   end Append;

   --  ------------------------------
   --  Sort the list of items on their names.
   --  ------------------------------
   procedure Sort (List : in out List_Definition) is
   begin
      Sorting.Sort (List.Nodes);
   end Sort;

   procedure Sort_On (List : in out List_Definition) is
      package Sorting is new Vectors.Generic_Sorting;
   begin
      Sorting.Sort (List.Nodes);
   end Sort_On;

   --  ------------------------------
   --  Find a definition given the name.
   --  Returns the definition object or null.
   --  ------------------------------
   function Find (Def  : in List_Definition;
                  Name : in String) return T_Access is
      Iter : Vectors.Cursor := Def.Nodes.First;
   begin
      while Vectors.Has_Element (Iter) loop
         if Vectors.Element (Iter).Get_Name = Name then
            return Vectors.Element (Iter);
         end if;
         Vectors.Next (Iter);
      end loop;
      return null;
   end Find;

   --  ------------------------------
   --  Iterate over the elements of the list executing the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Iterate (Def     : in List_Definition;
                      Process : not null access procedure (Item : in T_Access)) is
      Iter : Vectors.Cursor := Def.Nodes.First;
   begin
      while Vectors.Has_Element (Iter) loop
         Process (Vectors.Element (Iter));
         Vectors.Next (Iter);
      end loop;
   end Iterate;

end Gen.Model.List;

Fix GNAT 2020 compilation issue: use Set_Index procedure instead of setting the Row_Index member directory Trying to set the member generates a crash of the GNAT compiler


-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 2010 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 EL.Objects;
package body ASF.Components.Html is

   use EL.Objects;

   procedure Render_Attributes (UI      : in UIHtmlComponent;
                                Context : in out Faces_Context'Class;
                                Writer  : in ResponseWriter_Access) is
      Style  : constant Object := UI.Get_Attribute (Context, "style");
      Class  : constant Object := UI.Get_Attribute (Context, "styleClass");
   begin
      Writer.Write_Attribute ("id", UI.Get_Client_Id);
      if not Is_Null (Class) then
         Writer.Write_Attribute ("class", Class);
      end if;
      if not Is_Null (Style) then
         Writer.Write_Attribute ("style", Style);
      end if;
   end Render_Attributes;

end ASF.Components.Html;

-----------------------------------------------------------------------
--  html -- ASF HTML Components
--  Copyright (C) 2009, 2010 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 EL.Objects;
package body ASF.Components.Html is

   use EL.Objects;

   procedure Render_Attributes (UI      : in UIHtmlComponent;
                                Context : in out Faces_Context'Class;
                                Writer  : in ResponseWriter_Access) is
      Style  : constant Object := UI.Get_Attribute (Context, "style");
      Class  : constant Object := UI.Get_Attribute (Context, "styleClass");
      Title  : constant Object := UI.Get_Attribute (Context, "title");
   begin
      Writer.Write_Attribute ("id", UI.Get_Client_Id);
      if not Is_Null (Class) then
         Writer.Write_Attribute ("class", Class);
      end if;
      if not Is_Null (Style) then
         Writer.Write_Attribute ("style", Style);
      end if;
      if not Is_Null (Title) then
         Writer.Write_Attribute ("title", Title);
      end if;
   end Render_Attributes;

end ASF.Components.Html;

Add support for the title attribute

Add support for the title attribute