------------------------------------------------------------------------------
-- Scanner Resources                                                        --
--                                                                          --
-- Part of SparForte                                                        --
------------------------------------------------------------------------------
--                                                                          --
--            Copyright (C) 2001-2023 Free Software Foundation              --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- This is maintained at http://www.pegasoft.ca                             --
--                                                                          --
------------------------------------------------------------------------------

with ada.text_io,
     gnat.source_info,
     pegasoft.user_io,
     scanner.communications;
use  ada.text_io,
     pegasoft.user_io,
     scanner.communications;

#if BDB
  with bdb;
  use  bdb;
#end if;

package body scanner_res is

-- a list of resource handles.  the sort isn't used.

resHandles : resHandleList.List;

function resSort( left, right : resPtr ) return boolean is
begin
  return left.blocklvl < right.blocklvl; -- we don't care
end resSort;

function to_unbounded_string( id : resHandleID ) return unbounded_string is
begin
  return to_unbounded_string( long_float'image( long_float( id ) ) );
end to_unbounded_string;

function to_resource_id( val : unbounded_string ) return resHandleID is
  valAsLongFloat : long_float;
begin
  valAsLongFloat := long_float'value( to_string( val ) );
  return resHandleID( valAsLongFloat  );
end to_resource_id;

------------------------------------------------------------------------------


type hash_integer is mod 2**32;

function String_Hash( key : unbounded_string ) return Hash_Position is
-- FVN hash (see parser_numerics)
  hash   : hash_integer := 16#711c9dc5#; -- was 16#8
  k      : hash_integer;
  limit  : hash_integer;
begin
  limit := hash_integer( hash_position'last );
  for data in 1..length(key)-3 loop
      k := character'pos( element(key, data) ) +
           character'pos( element(key, data+1) ) * 256 +     -- 8
           character'pos( element(key, data+2) ) * 65536 +   -- 16
           character'pos( element(key, data+3) ) * 16777216; -- 24
       hash := hash xor k;
       hash := hash * 16#01000193#;
  end loop;
  hash := (hash mod limit);
  return hash_position( hash );
end String_Hash;

------------------------------------------------------------------------------

--function String_Hashed_Maps_Hash( key : unbounded_string ) return Ada.Containers.Hash_Type is
--begin
--  return Ada.Containers.Hash_Type( String_Hash( key ) );
--end String_Hashed_Maps_Hash;

------------------------------------------------------------------------------
--  DECLARE RESOURCE
--
-- Allocate a new resource record of the given type.  Record the block level
-- so it will be deallocated when that block is pulled from the scanner's
-- block table.  Returns 0 if the resource could not be allocated.
--
-- When assigning the block level, we want the block level of the variable
-- declaration, not the block level of the the current line.  For example,
-- a global variable (block level 1) and declaring a resource in a proc
-- (block level 2,3) will mean the resource will be discarded when the
-- procedure stops running if it's assigned block level 2 or 3.
-----------------------------------------------------------------------------

procedure declareResource( id : out resHandleID; rt : aResourceType; blocklvl : block; max_length : size_t := 0 ) is
  rp : resPtr;
begin
  rp := new resHandle( rt );

  rp.blocklvl := blocklvl;

  case rt is
  when gl_byte_array =>
     rp.gl_ba := new Byte_Array( 0..max_length );
  when gl_short_array =>
     rp.gl_sa := new Short_Array( 0..max_length );
  when gl_int_array =>
     rp.gl_ia := new Int_Array( 0..max_length );
  when gl_float_array =>
     rp.gl_fa := new Float_Array( 0..max_length );
  when gl_double_array =>
     rp.gl_da := new Double_Array( 0..max_length );
  when others =>
    null;
  end case;

  begin
    resHandleList.Queue( resHandles, rp );
  exception when storage_error =>
      err( +"out of memory" );
      id := 0;
      return;
  end;
  id := resHandleID( resHandleList.length( resHandles ) );
  if trace then
     put_trace( "Declared resource handle #" & id'img & " as a " & rt'img );
     put_trace( "There are" & resHandleList.length( resHandles )'img & " resource handles declared" );
  end if;
  exception when storage_error =>
      err( +"out of memory" );
      id := 0;
      return;
end declareResource;


-----------------------------------------------------------------------------
--  FIND RESOURCE
--
-- Search for a resource and return a pointer to it.  For a resource, it's
-- the position in the list indicated by the id number.
-----------------------------------------------------------------------------

procedure findResource( id : resHandleID; rp : out resPtr ) is
begin
  resHandleList.Find( resHandles, resHandleList.aListIndex( id ), rp );
end findResource;


-----------------------------------------------------------------------------
--  PUT RESOURCE
--
-- Display information about a resource.  For debugging.
-----------------------------------------------------------------------------

procedure putResource( rp : resPtr ) is
begin
  case rp.rt is
  when mysql_connection =>
       put_line_retry( "mysql connection" );
  when mysql_query =>
       put_line_retry( "mysql query" );
  when postgresql_connection =>
       put_line_retry( "postgresql connection" );
  when postgresql_query =>
       put_line_retry( "postgresql query" );
  when complex_number =>
       put_line_retry( "complex number" );
  when directory =>
       put_line_retry( "directory type" );
  when memcache_connection =>
       put_line_retry( "memcache connection" );
  when pen_canvas =>
       put_line_retry( "pen canvas" );
  when vector_string_list =>
       put_line_retry( "vector/singly linked list" );
  when vector_string_list_cursor =>
       put_line_retry( "vector/singly linked list cursor" );
  when doubly_linked_string_list =>
       put_line_retry( "doubly linked list" );
  when doubly_linked_string_list_cursor =>
       put_line_retry( "doubly linked list cursor" );
  when dynamic_string_hash_table =>
       put_line_retry( "dynamic hash table" );
  when string_hashed_map_cursor =>
       put_line_retry( "hashed map cursor" );
  when string_hashed_map =>
       put_line_retry( "hashed map" );
  when string_hashed_set_cursor =>
       put_line_retry( "hashed set cursor" );
  when string_hashed_set =>
       put_line_retry( "hashed set" );
  when gl_byte_array  =>
       put_line_retry( "OpenGL byte array" );
  when gl_short_array  =>
       put_line_retry( "OpenGL short array" );
  when gl_int_array =>
       put_line_retry( "OpenGL int array" );
  when gl_float_array  =>
       put_line_retry( "OpenGL float array" );
  when gl_double_array  =>
       put_line_retry( "OpenGL doubly array" );
  when btree_file =>
       put_line_retry( "btree file" );
  when hash_file =>
       put_line_retry( "hash file" );
  when recno_file =>
       put_line_retry( "recno file" );
  when btree_cursor =>
       put_line_retry( "btree cursor" );
  when hash_cursor =>
       put_line_retry( "hash cursor" );
  when recno_cursor =>
       put_line_retry( "recno cursor" );
  when tinyserve_socket_server =>
       put_line_retry( "tinyserve socket server" );
  when none =>
       put_line_retry( "undefined resource" );
  when others =>
       put_line_retry( standard_error, gnat.source_info.source_location & ": internal error: unexpected resource" );
  end case;
end putResource;


-----------------------------------------------------------------------------
--  CLEAR RESOURCE
--
-- Free the memory used by a resource.  Close/disconnect the resource first.
-----------------------------------------------------------------------------

procedure clearResource( id : resHandleID ) is
  rp : resPtr;
begin
  -- TODO: free handle
  resHandleList.find( resHandles, resHandleList.aListIndex( id ), rp );
  if rp.rt = mysql_connection then
#if MYSQL
     if APQ.MySQL.Client.is_trace( rp.C ) then
        APQ.MySQL.Client.close_Db_Trace( rp.C );
     end if;
     if APQ.MySQL.Client.is_connected( rp.C ) then
        APQ.MySQL.Client.disconnect( rp.C );
     end if;
#else
     null;
#end if;
  elsif rp.rt = mysql_query then
     Free( rp );
  elsif rp.rt = postgresql_connection then
#if POSTGRES
     if APQ.PostgreSQL.Client.is_trace( rp.PG_C ) then
        APQ.PostgreSQL.Client.close_Db_Trace( rp.PG_C );
     end if;
     if APQ.PostgreSQL.Client.is_connected( rp.PG_C ) then
        APQ.PostgreSQL.Client.disconnect( rp.PG_C );
     end if;
#else
     null;
#end if;
  elsif rp.rt = postgresql_query then
     Free( rp );
  elsif rp.rt = directory then
     if is_open( rp.dir ) then
        close( rp.dir );
     end if;
  elsif rp.rt = vector_string_list then
     vector_string_lists.clear( rp.vslVector );
  elsif rp.rt = doubly_linked_string_list then
     doubly_linked_string_lists.clear( rp.dlslList );
  elsif rp.rt = dynamic_string_hash_table then
     dynamic_string_hash_tables.reset( rp.dsht );
  elsif rp.rt = string_hashed_map then
     string_hashed_maps.clear( rp.shmMap );
  elsif rp.rt = string_hashed_set then
     string_hashed_sets.clear( rp.shsSet );
  elsif rp.rt = gl_byte_array then
     Free( rp.gl_ba );
  elsif rp.rt = gl_short_array then
     Free( rp.gl_sa );
  elsif rp.rt = gl_int_array then
     Free( rp.gl_ia );
  elsif rp.rt = gl_float_array then
     Free( rp.gl_fa );
  elsif rp.rt = gl_double_array then
     Free( rp.gl_da );
  elsif rp.rt = btree_file then
#if BDB
     if rp.btree.isOpen then
        -- close the database
        begin
           close( rp.btree.session );
        exception when berkeley_error =>
           err_exception_raised;
        end;
        -- close the environment
        begin
           close( rp.btree.env );
        exception when berkeley_error =>
           err_exception_raised;
        end;
     end if;
     -- free the I/O buffer memory
     free_berkeley_session( rp.btree.session );
#else
     null;
#end if;
  elsif rp.rt = hash_file then
#if BDB
     if rp.hash.isOpen then
        -- close the database
        begin
           close( rp.hash.session );
        exception when berkeley_error =>
           err_exception_raised;
        end;
        -- close the environment
        begin
           close( rp.hash.env );
        exception when berkeley_error =>
           err_exception_raised;
        end;
     end if;
     -- free the I/O buffer memory
     free_berkeley_session( rp.hash.session );
#else
     null;
#end if;
  elsif rp.rt = recno_file then
#if BDB
     if rp.recno.isOpen then
        -- close the database
        begin
           close( rp.recno.session );
        exception when berkeley_error =>
           err_exception_raised;
        end;
        -- close the environment
        begin
           close( rp.recno.env );
        exception when berkeley_error =>
           err_exception_raised;
        end;
     end if;
     -- free the I/O buffer memory
     free_berkeley_session( rp.recno.session );
#else
     null;
#end if;
  elsif rp.rt = btree_cursor then
#if BDB
     -- TODO: The session is shallow copied, so closing the original session
     -- early has uncertain effects.
     if rp.btree_cur.isOpen then
        begin
           close( rp.btree_cur.session, rp.btree_cur.cursor );
        exception when berkeley_error =>
          err_exception_raised;
        end;
     end if;
#else
     null;
#end if;
  elsif  rp.rt = hash_cursor then
#if BDB
     -- TODO: The session is shallow copied, so closing the original session
     -- early has uncertain effects.
     if rp.hash_cur.isOpen then
        begin
           close( rp.hash_cur.session, rp.hash_cur.cursor );
        exception when berkeley_error =>
          err_exception_raised;
        end;
     end if;
#else
     null;
#end if;
  elsif  rp.rt = recno_cursor then
      null;
      -- TODO: this is temporary: at least tell the user cursor wasn't closed
      --if rp.recno_cur.isOpen then
      --   err( "cursor is not closed" );
      --end if;
  end if;
-- TODO: should close tinyserve server if open
  resHandleList.clear( resHandles, long_integer( id ) );
  --if trace then
  --   put_trace( "Resource handle" & id'img & " memory freed" );
  --end if;
  exception when STORAGE_ERROR =>
    err( pl( gnat.source_info.source_location & ": internal error: STORAGE_ERROR raised when clearning resource" & id'img & " a " & rp.rt'img ) );
end clearResource;


-----------------------------------------------------------------------------
--  PULL RESOURCE BLOCK
--
-- When a scanner block is destroyed, clear all resources associated with
-- this block.
-----------------------------------------------------------------------------

procedure pullResourceBlock( blocklvl : block ) is
  rp : resPtr;
begin
  for i in reverse 1..resHandleList.length( resHandles ) loop  -- look thru arrays
      resHandleList.Find( resHandles, i, rp );               -- next array
      exit when rp.blocklvl < blocklvl;                      -- completed block?
      clearResource( resHandleID( i ) );                     -- dealloc memory
      resHandleList.Clear( resHandles, i );                  -- destroy entry
      if trace then
         put_trace( "Resource handle" & i'img & " deallocated" );
      end if;
  end loop;
  if trace then
     put_trace( "There are" & resHandleList.length( resHandles )'img & " resources allocated" );
  end if;
end pullResourceBlock;

end scanner_res;

