No edit summary
No edit summary
Line 1: Line 1:
<pre>
<syntaxhighlight>
-- JSON.ADS VINCENT MORIN 25/2/2025 UNIVERSITE DE BRETAGNE OCCIDENTALE (UBO)
-- JSON.ADS VINCENT MORIN 25/2/2025 UNIVERSITE DE BRETAGNE OCCIDENTALE (UBO)
-------------------------------------------------------------------------------------------------------------------------
-------------------------------------------------------------------------------------------------------------------------
Line 115: Line 115:
-- 1 2 3 4 5 6 7 8 9 0 1 2
-- 1 2 3 4 5 6 7 8 9 0 1 2
-------------------------------------------------------------------------------------------------------------------------
-------------------------------------------------------------------------------------------------------------------------
</pre>
</syntaxhighlight>
 
The package body :
<syntaxhighlight>
-- JSON.ADB VINCENT MORIN 25/2/2025 UNIVERSITE DE BRETAGNE OCCIDENTALE (UBO)
-------------------------------------------------------------------------------------------------------------------------
-- 1 2 3 4 5 6 7 8 9 0 1 2
 
 
with UNCHECKED_DEALLOCATION, DIRECT_IO;
 
----
package body JSON
----
is
 
  DEBUG : BOOLEAN := FALSE;
 
 
---
  procedure GET ( FILE :in JSON.FILE_TYPE; THE_ITEM :out ITEM )
  ---
  is
    use TEXT_IO;
 
------
  package PARSER
------
  is
 
    function  READ_OBJECT return JSON.ITEM;
 
------
  end PARSER;
------
 
  package body PARSER
------
  is
 
 
    type TOKEN_TYPE is ( END_TOKEN, LEFT_ACCOLADE, RIGHT_ACCOLADE, LEFT_CROCHET, RIGHT_CROCHET,
    COMMA, COLON, CHAINE, ENTIER, FLOTTANT );
 
    type TOKEN (KIND :TOKEN_TYPE := END_TOKEN) is record
  case KIND is
  when CHAINE => STR_LENGTH : NATURAL;
  when ENTIER => INT_VALUE : INTEGER;
  when FLOTTANT => FLOAT_VALUE : LONG_FLOAT;
  when others => null;
  end case;
end record;
 
    TOKEN_BUFFER : STRING( 1 .. 512 );
 
 
 
--------------------
  procedure PROCESS_SYNTAX_ERROR ( ENCOUNTERED, EXPECTED : TOKEN_TYPE := END_TOKEN )
  --------------------
  is
    use TEXT_IO;
  begin
    PUT( "syntax error ! (" & COUNT'IMAGE( TEXT_IO.LINE( FILE ) )
  & ':' & COUNT'IMAGE( TEXT_IO.COL( FILE )-1 ) & ") : " );
 
    if  ENCOUNTERED = END_TOKEN  and  EXPECTED = END_TOKEN
    then
      PUT_LINE( "unexpected end of file " );
 
    else
      if  EXPECTED /= END_TOKEN
      then
        PUT( "expected " & TOKEN_TYPE'IMAGE( EXPECTED ) );
      end if;
 
      if  ENCOUNTERED /= END_TOKEN
      then
        PUT_LINE( " encountered " & TOKEN_TYPE'IMAGE( ENCOUNTERED ) );
      else
        NEW_LINE;
      end if;
 
    end if;
 
    raise PROGRAM_ERROR;
 
  end PROCESS_SYNTAX_ERROR;
--------------------
 
 
 
---
  procedure GET ( THE_TOKEN :out TOKEN )
---
  is
    use TEXT_IO;
    C : CHARACTER;
  begin
    THE_TOKEN := ( KIND=> END_TOKEN );
 
-----------
SKIP_BLANKS:
    loop
      if  END_OF_FILE( FILE )  then  return;  end if;
      GET( FILE, C );
      exit when  not (C = ' '  or  C = ASCII.HT);
      if  END_OF_FILE( FILE )  then  return;  end if;
 
    end loop SKIP_BLANKS;
-----------
 
    if  DEBUG
    then
      PUT( C & TEXT_IO.COUNT'IMAGE( TEXT_IO.LINE( FILE ) ) & ':'
  & TEXT_IO.COUNT'IMAGE( TEXT_IO.COL(FILE )-1 ) & '.' );
    end if;
 
    case  C  is
 
      when  '{'
  => THE_TOKEN := ( KIND=> LEFT_ACCOLADE  );
 
      when  '}'
  => THE_TOKEN := ( KIND=> RIGHT_ACCOLADE );
 
      when  '['
  => THE_TOKEN := ( KIND=> LEFT_CROCHET  );
 
      when  ']'
  => THE_TOKEN := ( KIND=> RIGHT_CROCHET  );
 
      when  ','
  => THE_TOKEN := ( KIND=> COMMA );
 
      when  ':'
  => THE_TOKEN := ( KIND=> COLON );
 
      when  '"'
  => ------------
GET_A_STRING:
        declare
LEN : NATURAL := 0;
INDEX_BUFFER : POSITIVE := 1;
        begin
loop
  GET( FILE, C );
 
  if  DEBUG
  then
    PUT( C & TEXT_IO.COUNT'IMAGE( TEXT_IO.LINE( FILE ) ) & ':'
& TEXT_IO.COUNT'IMAGE( TEXT_IO.COL( FILE )-1 ) & '.' );
  end if;
 
            exit when  C = '"';
  TOKEN_BUFFER( INDEX_BUFFER ) := C;
  LEN := LEN + 1;
  INDEX_BUFFER := INDEX_BUFFER + 1;
end loop;
THE_TOKEN := ( KIND=> CHAINE, STR_LENGTH=> LEN );
 
        end GET_A_STRING;
------------
 
      when  others
  => raise SYNTAX_ERROR;
 
    end case;
 
    if  DEBUG
    then
      PUT( "token " & TOKEN_TYPE'IMAGE( THE_TOKEN.KIND ) & " at"
& TEXT_IO.COUNT'IMAGE( TEXT_IO.LINE( FILE ) ) & ':'
& TEXT_IO.COUNT'IMAGE( TEXT_IO.COL( FILE )-1 )
        );
      if THE_TOKEN.KIND = CHAINE
      then  PUT_LINE( "  " & '"' & TOKEN_BUFFER( 1 .. THE_TOKEN.STR_LENGTH ) & '"' );
      else  NEW_LINE;
      end if;
    end if;
 
  exception
    when END_ERROR | SYNTAX_ERROR => PROCESS_SYNTAX_ERROR;
 
  end GET;
---
 
 
 
----------
  procedure GET_VERIFY ( WHAT_IS_EXPECTED :TOKEN_TYPE; THE_TOKEN :out TOKEN )
----------
  is
  begin
    GET( THE_TOKEN );
    if  THE_TOKEN.KIND /= WHAT_IS_EXPECTED
    then
      PROCESS_SYNTAX_ERROR( ENCOUNTERED=> THE_TOKEN.KIND, EXPECTED=> WHAT_IS_EXPECTED );
    end if;
 
  end GET_VERIFY;
----------
 
 
 
  function  GET_OBJECT return JSON.ITEM;
  function  GET_ARRAY return JSON.ITEM;
 
 
 
--------
  function GET_ITEM ( THE_TOKEN :TOKEN ) return JSON.ITEM
--------
  is
  begin
 
    case  THE_TOKEN.KIND  is
 
      when  LEFT_ACCOLADE
  => return GET_OBJECT;
 
      when  LEFT_CROCHET
  => return GET_ARRAY;
 
      when  CHAINE
  => return new ITEM_DEFINITION'( KIND=> STRING_ITEM,
    STR_ACCESS=> new STRING'(TOKEN_BUFFER( 1 .. THE_TOKEN.STR_LENGTH )) );
 
      when  ENTIER
  => return new ITEM_DEFINITION'( KIND=> INTEGER_ITEM, INT_VAL=> THE_TOKEN.INT_VALUE );
 
      when  FLOTTANT
  => return new ITEM_DEFINITION'( KIND=> FLOAT_ITEM, FLOAT_VAL=> THE_TOKEN.FLOAT_VALUE );
 
      when  others
  => raise SYNTAX_ERROR;
 
    end case;
 
  exception
    when SYNTAX_ERROR
        => PROCESS_SYNTAX_ERROR( THE_TOKEN.KIND );
  raise PROGRAM_ERROR;
 
  end GET_ITEM;
--------
 
 
 
----------
    function GET_OBJECT return JSON.ITEM
----------
    is
      THE_TOKEN : TOKEN;
      FIELDS_LIST_HEAD,
      FIELDS_LIST_LAST : OBJECT_FIELD_ACCESS := null;
 
    begin
      GET( THE_TOKEN );
      if  THE_TOKEN.KIND = RIGHT_ACCOLADE  then  return new ITEM_DEFINITION'( OBJECT_ITEM, null );  end if;
      if  THE_TOKEN.KIND /= CHAINE  then  PROCESS_SYNTAX_ERROR;  end if;
 
      loop
 
        declare
KEY : STRING_ACCESS := new STRING'(TOKEN_BUFFER( 1 .. THE_TOKEN.STR_LENGTH ));
OFA : OBJECT_FIELD_ACCESS;
        begin
GET_VERIFY( COLON, THE_TOKEN );
GET( THE_TOKEN );
OFA := new OBJECT_FIELD'( KEY, GET_ITEM( THE_TOKEN ), null );
 
if  FIELDS_LIST_HEAD = null  then
  FIELDS_LIST_HEAD := OFA; FIELDS_LIST_LAST := OFA;
else
  FIELDS_LIST_LAST.all.NEXT := OFA; FIELDS_LIST_LAST := OFA;
end if;
        end;
 
        GET( THE_TOKEN );
        if  THE_TOKEN.KIND = COMMA
        then
GET_VERIFY( CHAINE, THE_TOKEN );
        else
if  THE_TOKEN.KIND /= RIGHT_ACCOLADE
then
  PROCESS_SYNTAX_ERROR( ENCOUNTERED=> THE_TOKEN.KIND, EXPECTED=> RIGHT_ACCOLADE );
end if;
exit;
        end if;
 
      end loop;
 
      return new ITEM_DEFINITION'( OBJECT_ITEM, FIELDS_LIST_HEAD );
 
    end GET_OBJECT;
----------
 
 
---------
    function GET_ARRAY return JSON.ITEM
---------
    is
      THE_TOKEN : TOKEN;
      STRUC_LIST_HEAD,
      STRUC_LIST_LAST : LIST_OF_ITEMS := null;
 
    begin
      GET( THE_TOKEN );
      if  THE_TOKEN.KIND = RIGHT_CROCHET  then  return new ITEM_DEFINITION'( ARRAY_ITEM, null );  end if;
 
-------------
PROCESS_ITEMS:
      loop
 
        declare
LOI : LIST_OF_ITEMS := new ITEM_LIST_ELEMENT'( GET_ITEM( THE_TOKEN ), null );
        begin
if  STRUC_LIST_HEAD = null  then
  STRUC_LIST_HEAD := LOI; STRUC_LIST_LAST := LOI;
else
  STRUC_LIST_LAST.all.NEXT := LOI; STRUC_LIST_LAST := LOI;
end if;
        end;
 
        GET( THE_TOKEN );
        if  THE_TOKEN.KIND = COMMA
        then
GET( THE_TOKEN );
        else
if  THE_TOKEN.KIND = RIGHT_CROCHET
then  exit PROCESS_ITEMS;
else  PROCESS_SYNTAX_ERROR( ENCOUNTERED=> THE_TOKEN.KIND, EXPECTED=> RIGHT_CROCHET );
end if;
        end if;
 
      end loop PROCESS_ITEMS;
-------------
 
      return new ITEM_DEFINITION'( ARRAY_ITEM, STRUC_LIST_HEAD );
 
    end GET_ARRAY;
----------
 
 
 
-----------
    function READ_OBJECT return JSON.ITEM
  -----------
    is
      THE_TOKEN : TOKEN;
    begin
      GET( THE_TOKEN );
      if  THE_TOKEN.KIND = LEFT_ACCOLADE  then
        return GET_OBJECT;
      else  raise SYNTAX_ERROR;
      end if;
 
    exception
      when SYNTAX_ERROR
  => PROCESS_SYNTAX_ERROR;
    raise PROGRAM_ERROR;
 
    end READ_OBJECT;
-----------
 
 
------
  end PARSER;
------
 
-- 1 2 3 4 5 6 7 8 9 0 1 2
-------------------------------------------------------------------------------------------------------------------------
 
 
  begin
    THE_ITEM := PARSER.READ_OBJECT;
 
  end GET;
---
 
---
  procedure PUT ( FILE :in out JSON.FILE_TYPE; THE_ITEM :ITEM )
---
  is
  -------
    procedure   LAY_ONE ( ITEM :JSON.ITEM; AT_COL :TEXT_IO.COUNT )
  -------
    is
      use TEXT_IO;
    -----------------
      procedure     PUT_OBJECT_FIELDS ( OF_OBJECT :JSON.ITEM )
    -----------------
      is
      -----------------
        procedure       PROCESS_ONE_FIELD ( KEY     :STRING;
  ITEM     :in out JSON.ITEM;
  LAST_ONE    :in BOOLEAN;
  STOP_PROCESS :out BOOLEAN )
      -----------------
        is
        begin
SET_COL( AT_COL+2 );
PUT( '"' & KEY & '"' & " : " );
 
LAY_ONE( ITEM, TEXT_IO.COL );
 
if  not LAST_ONE  then  PUT( ',' );  end if; NEW_LINE;
STOP_PROCESS := FALSE;
 
        end   PROCESS_ONE_FIELD;
  -----------------
 
        procedure PUT_FOR_EACH_FIELD is new FOR_EACH_JSON_FIELD( PROCESS_ONE_FIELD );
 
      begin
PUT_FOR_EACH_FIELD( OF_OBJECT );
 
      end PUT_OBJECT_FIELDS;
-----------------
 
    ---------------
      procedure     PUT_ARRAY_ITEMS (THE_ITEM :JSON.ITEM )
    ---------------
      is
        START_COL : TEXT_IO.COUNT := TEXT_IO.COL;
 
      ----------------
procedure       PROCESS_ONE_ITEM ( ITEM     :in out JSON.ITEM;
  LAST_ONE    :in BOOLEAN;
  STOP_PROCESS :out BOOLEAN )
      ----------------
is
begin
  NEW_LINE;
 
  LAY_ONE( ITEM, START_COL+2 );
 
  if  not LAST_ONE  then  PUT( ',' );  end if;
  STOP_PROCESS := FALSE;
 
end     PROCESS_ONE_ITEM;
    ----------------
 
procedure PUT_FOR_EACH_ITEM is new FOR_EACH_JSON_ITEM( PROCESS_ONE_ITEM );
 
      begin
        PUT_FOR_EACH_ITEM( ITEM );
 
      end PUT_ARRAY_ITEMS;
---------------
 
    begin
      SET_COL( AT_COL );
 
      case KIND( ITEM ) is
 
      when OBJECT_ITEM
=>
PUT( '{' );
PUT_OBJECT_FIELDS( ITEM );
SET_COL( AT_COL+1 );
PUT( '}' );
 
      when ARRAY_ITEM
=>
PUT( '[' );
PUT_ARRAY_ITEMS( ITEM );
SET_COL( AT_COL+1 );
PUT( ']' );
 
      when STRING_ITEM
=>
PUT( '"' & ITEM.all.STR_ACCESS.all & '"' );
 
      when INTEGER_ITEM
=>
PUT( INTEGER'IMAGE( ITEM.all.INT_VAL ) );
 
      when FLOAT_ITEM
=>
declare
  package LONG_FLOAT_IO is new FLOAT_IO( LONG_FLOAT );
  begin
    LONG_FLOAT_IO.PUT( ITEM.all.FLOAT_VAL );
  end;
 
      when BOOLEAN_ITEM
=>
PUT( BOOLEAN'IMAGE( ITEM.all.BOOL_VAL ) );
 
      when NULL_ITEM
=>
PUT( "null" );
 
      end case;
 
    end   LAY_ONE;
  -------
 
  begin
    TEXT_IO.SET_OUTPUT( FILE );
    LAY_ONE( THE_ITEM, AT_COL=> 1 );
    TEXT_IO.SET_OUTPUT( TEXT_IO.STANDARD_OUTPUT );
 
  end PUT;
---
 
 
---------
  function STRING_OF ( THE_ITEM : ITEM) return STRING
---------
  is
    TEMP_FILE_NAME :constant STRING := "JSON$$$.tmp";
  begin
------------------
WRITE_ITEM_TO_FILE:
    declare
      TEMP_FILE : TEXT_IO.FILE_TYPE;
      use TEXT_IO;
    begin
      CREATE( TEMP_FILE, OUT_FILE, TEMP_FILE_NAME );
      JSON.PUT( TEMP_FILE, THE_ITEM );
      CLOSE( TEMP_FILE );
 
    end WRITE_ITEM_TO_FILE;
------------------
 
-------------------
READ_FILE_TO_STRING:
    declare
      package CHAR_IO is new DIRECT_IO( CHARACTER );
      use CHAR_IO;
      TEMP_FILE : CHAR_IO.FILE_TYPE;
    begin
      CHAR_IO.OPEN( TEMP_FILE, IN_FILE, TEMP_FILE_NAME );
      declare
        ITEM_STRING_LENGTH :constant INTEGER := INTEGER( CHAR_IO.SIZE( TEMP_FILE ) );
        ITEM_STRING : STRING( 1 .. ITEM_STRING_LENGTH );
      begin
        for I in ITEM_STRING'RANGE loop
READ( TEMP_FILE, ITEM_STRING( I ) );
        end loop;
        DELETE( TEMP_FILE );
        return  ITEM_STRING;
      end;
 
    end READ_FILE_TO_STRING;
-------------------
 
  end STRING_OF;
---------
 
 
 
-------
  function ITEM_OF ( THE_STRING :STRING) return ITEM
  -------
  is
    TEMP_FILE_NAME :constant STRING := "JSON$$$.tmp";
    OUT_ITEM : ITEM;
 
  begin
    declare
      package CHAR_IO is new DIRECT_IO( CHARACTER );
      use CHAR_IO;
      TEMP_FILE : CHAR_IO.FILE_TYPE;
    begin
      CREATE( TEMP_FILE, OUT_FILE, TEMP_FILE_NAME );
      for I in THE_STRING'RANGE loop
        WRITE( TEMP_FILE, THE_STRING( I ) );
      end loop;
      CLOSE( TEMP_FILE );
    end;
 
    declare
      use TEXT_IO;
      TEMP_FILE : JSON.FILE_TYPE;
    begin
      TEXT_IO.OPEN( TEMP_FILE, IN_FILE, TEMP_FILE_NAME );
      JSON.GET( TEMP_FILE, OUT_ITEM );
      OPEN( TEMP_FILE, IN_FILE, TEMP_FILE_NAME );
      DELETE( TEMP_FILE );
    end;
    return  OUT_ITEM;
 
  end ITEM_OF;
-------
 
 
 
--  J S O N  S T R U C T U R E  I N T E R A C T I O N
 
 
----
  function KIND ( OF_ITEM :ITEM ) return ITEM_TYPE
  is
  begin
    return  OF_ITEM.all.KIND;
 
  end KIND;
----
 
 
 
----------
  function IS_PRESENT ( KEY :STRING; IN_OBJECT :ITEM ) return BOOLEAN
  ----------
  is
    SEARCH_KEY : STRING renames KEY;
    KEY_SEEN : BOOLEAN := FALSE;
 
-------
    procedure PROCESS ( THE_KEY     :STRING;
  THE_ITEM    :in out ITEM;
  LAST_ONE    :in BOOLEAN;
  STOP_PROCESS :out BOOLEAN )
    is -------
    begin
      if  THE_KEY = SEARCH_KEY  then  KEY_SEEN := TRUE;  end if;
      STOP_PROCESS := KEY_SEEN;
 
    end PROCESS;
-------
 
    procedure SCAN is new FOR_EACH_JSON_FIELD( PROCESS );
 
 
  begin
    if  IN_OBJECT.all.KIND /= OBJECT_ITEM  then  raise BAD_ITEM_TYPE;  end if;
 
    SCAN( IN_OBJECT );
    return  KEY_SEEN;
 
  end IS_PRESENT;
----------
 
 
 
-----------
  function ITEM_BY_KEY ( KEY :STRING; IN_OBJECT :ITEM ) return ITEM
-----------
  is
    SEARCH_KEY : STRING renames KEY;
    FOUND_ITEM : ITEM := null;
 
-------
    procedure PROCESS ( THE_KEY     :STRING;
  THE_ITEM    :in out ITEM;
  LAST_ONE    :in BOOLEAN;
  STOP_PROCESS :out BOOLEAN )
    is -------
    begin
      if  THE_KEY = SEARCH_KEY  then  FOUND_ITEM := THE_ITEM;  end if;
      STOP_PROCESS := (FOUND_ITEM /= null);
 
    end PROCESS;
-------
 
    procedure SCAN is new FOR_EACH_JSON_FIELD( PROCESS );
 
 
  begin
    if  IN_OBJECT.all.KIND /= OBJECT_ITEM  then  raise BAD_ITEM_TYPE;  end if;
 
    SCAN( IN_OBJECT );
    if  FOUND_ITEM = null  then  raise VALUE_NOT_FOUND;  end if;
    return  FOUND_ITEM;
 
  end ITEM_BY_KEY;
------------
 
 
 
----------
  function ITEM_VALUE ( OF_ITEM :ITEM ) return VALUE_DATA
----------
  is
  begin
    case KIND( OF_ITEM ) is
 
      when OBJECT_ITEM | ARRAY_ITEM
=>
  raise BAD_ITEM_TYPE;
 
      when STRING_ITEM
=>
  declare
    THE_STRING : STRING renames OF_ITEM.all.STR_ACCESS.all;
    STRING_LENGTH :constant NATURAL := THE_STRING'LENGTH;
  begin
    return ( STRING_ITEM, STRING_LENGTH, THE_STRING );
  end;
 
      when INTEGER_ITEM
=>
  return ( INTEGER_ITEM, 0, OF_ITEM.all.INT_VAL );
 
      when FLOAT_ITEM
=>
  return ( FLOAT_ITEM, 0, OF_ITEM.all.FLOAT_VAL );
 
      when BOOLEAN_ITEM
=>
  return ( BOOLEAN_ITEM, 0, OF_ITEM.all.BOOL_VAL );
 
      when NULL_ITEM
=>
  return ( NULL_ITEM, 0 );
 
      end case;
 
  end ITEM_VALUE;
----------
 
 
 
-------------------
  function NUMBER_OF_SUB_ITEMS ( IN_ITEM :ITEM ) return NATURAL
-------------------
  is
    COUNT : NATURAL := 0;
  begin
    case KIND( IN_ITEM ) is
 
      when OBJECT_ITEM
=>
  declare
    THE_LIST : OBJECT_FIELD_ACCESS := IN_ITEM.all.FIELDS_LIST;
  begin
    while  THE_LIST /= null  loop
      COUNT := COUNT + 1;
      THE_LIST := THE_LIST.all.NEXT;
    end loop;
  end;
 
      when ARRAY_ITEM
=>
  declare
    THE_LIST : LIST_OF_ITEMS := IN_ITEM.all.ITEMS_LIST;
  begin
    while  THE_LIST /= null  loop
      COUNT := COUNT + 1;
      THE_LIST := THE_LIST.all.NEXT;
    end loop;
  end;
 
      when others => null;
 
      end case;
      return COUNT;
 
  end NUMBER_OF_SUB_ITEMS;
-------------------
 
 
 
----
  procedure FREE ( THE_ITEM :in out ITEM )
----
  is
    procedure FREE is new UNCHECKED_DEALLOCATION( ITEM_DEFINITION, ITEM );
    procedure FREE is new UNCHECKED_DEALLOCATION( OBJECT_FIELD, OBJECT_FIELD_ACCESS );
    procedure FREE is new UNCHECKED_DEALLOCATION( ITEM_LIST_ELEMENT, LIST_OF_ITEMS );
    procedure FREE is new UNCHECKED_DEALLOCATION( STRING, STRING_ACCESS );
  begin
    case KIND( THE_ITEM ) is
 
      when OBJECT_ITEM
=>
  declare
    THE_LIST : OBJECT_FIELD_ACCESS := THE_ITEM.all.FIELDS_LIST;
    SUITE : OBJECT_FIELD_ACCESS;
  begin
    while  THE_LIST /= null  loop
      FREE( THE_LIST.all.FIELD_KEY );
      FREE( THE_LIST.all.FIELD_ITEM );
      SUITE := THE_LIST.all.NEXT;
      FREE( THE_LIST );
      THE_LIST := SUITE;
    end loop;
  end;
 
      when ARRAY_ITEM
=>
  declare
    THE_LIST : LIST_OF_ITEMS := THE_ITEM.all.ITEMS_LIST;
    SUITE : LIST_OF_ITEMS;
  begin
    while  THE_LIST /= null  loop
      FREE( THE_LIST.all.LIST_ITEM );
      SUITE := THE_LIST.all.NEXT;
      FREE( THE_LIST );
      THE_LIST := SUITE;
    end loop;
  end;
 
      when others => null;
 
      end case;
 
      THE_ITEM.all := ( KIND=> NULL_ITEM );
 
  end FREE;
----
 
 
 
------------------
  procedure FOR_EACH_JSON_ITEM ( OF_ARRAY :JSON.ITEM )
------------------
  is
  begin
    if  OF_ARRAY = null  or else  OF_ARRAY.all.KIND /= ARRAY_ITEM  then  raise BAD_ITEM_TYPE;  end if;
 
    declare
      STOP_PROCESS : BOOLEAN;
      ITEM_LIST : LIST_OF_ITEMS := OF_ARRAY.all.ITEMS_LIST;
      LAST_ONE : BOOLEAN;
    begin
      loop
        exit when  ITEM_LIST = null;
        LAST_ONE := (ITEM_LIST.all.NEXT = null);
        APPLY_PROCESS( ITEM_LIST.all.LIST_ITEM, LAST_ONE, STOP_PROCESS );
        exit when  STOP_PROCESS;
        ITEM_LIST := ITEM_LIST.all.NEXT;
      end loop;
    end;
 
  end FOR_EACH_JSON_ITEM;
------------------
 
 
 
-------------------
  procedure FOR_EACH_JSON_FIELD ( OF_OBJECT :JSON.ITEM )
-------------------
  is
  begin
    if  OF_OBJECT = null  or else  OF_OBJECT.all.KIND /= OBJECT_ITEM  then  raise BAD_ITEM_TYPE;  end if;
 
    declare
      FIELDS : OBJECT_FIELD_ACCESS := OF_OBJECT.all.FIELDS_LIST;
      STOP_PROCESS : BOOLEAN;
      LAST_ONE : BOOLEAN;
    begin
      while  FIELDS /= null  loop
        LAST_ONE := (FIELDS.all.NEXT = null);
        APPLY_PROCESS( FIELDS.all.FIELD_KEY.all, FIELDS.all.FIELD_ITEM, LAST_ONE, STOP_PROCESS );
        exit when  STOP_PROCESS;
        FIELDS := FIELDS.all.NEXT;
      end loop;
    end;
 
  end FOR_EACH_JSON_FIELD;
-------------------
 
 
 
----
end JSON;
----
 
-- 1 2 3 4 5 6 7 8 9 0 1 2
-------------------------------------------------------------------------------------------------------------------------


<syntaxhighlight>
The package body : [[JSON_bdy]]

Revision as of 09:43, 3 March 2025

--	JSON.ADS	VINCENT MORIN	25/2/2025		UNIVERSITE DE BRETAGNE OCCIDENTALE	(UBO)
-------------------------------------------------------------------------------------------------------------------------
--	1	2	3	4	5	6	7	8	9	0	1	2


with TEXT_IO;
						----
			package			JSON
						----
is
  type ITEM		is private;

  type ITEM_TYPE		is ( OBJECT_ITEM, ARRAY_ITEM,
			     STRING_ITEM, INTEGER_ITEM, FLOAT_ITEM, BOOLEAN_ITEM, NULL_ITEM );

  subtype TERMINAL_TYPE	is ITEM_TYPE range STRING_ITEM .. NULL_ITEM;

  subtype FILE_TYPE		is TEXT_IO.FILE_TYPE;

  MAX_STRING_LENGTH		:constant NATURAL	:= 2**15-1;
  subtype STRING_LENGTH	is NATURAL range 0 .. MAX_STRING_LENGTH;

  type VALUE_DATA (KIND :TERMINAL_TYPE := NULL_ITEM; LENGTH :STRING_LENGTH := 0)
			is record
			  case  KIND
			  is
			    when STRING_ITEM	=> STRING_VAL	:STRING( 1 .. LENGTH );
			    when INTEGER_ITEM	=> INT_VAL	:INTEGER;
			    when FLOAT_ITEM		=> FLOAT_VAL	:LONG_FLOAT;
			    when BOOLEAN_ITEM	=> BOOL_VAL	:BOOLEAN;
			    when NULL_ITEM		=> null;
			  end case;
			end record;


				--  J S O N   I T E M   I / O


  procedure GET			( FILE :in JSON.FILE_TYPE; THE_ITEM :out ITEM );
  procedure PUT			( FILE :in out JSON.FILE_TYPE; THE_ITEM :ITEM );
  function  STRING_OF		( THE_ITEM :ITEM)				return STRING;
  function  ITEM_OF			( THE_STRING :STRING)			return ITEM;


				--  J S O N   I T E M   I N T E R A C T I O N


  function  KIND			( OF_ITEM :ITEM )				return ITEM_TYPE;
  function  IS_PRESENT		( KEY :STRING; IN_OBJECT :ITEM )		return BOOLEAN;
  function  ITEM_BY_KEY		( KEY :STRING; IN_OBJECT :ITEM )		return ITEM;
  function  ITEM_VALUE		( OF_ITEM :ITEM )				return VALUE_DATA;
  function  NUMBER_OF_SUB_ITEMS	( IN_ITEM :ITEM )				return NATURAL;
  procedure FREE			( THE_ITEM :in out ITEM );

  generic
    with procedure APPLY_PROCESS ( ON_ITEM :in out ITEM; LAST_ONE :in BOOLEAN; STOP_PROCESS :out BOOLEAN );
  procedure FOR_EACH_JSON_ITEM	( OF_ARRAY :ITEM );

  generic
    with procedure APPLY_PROCESS ( KEY :STRING; ON_ITEM :in out ITEM; LAST_ONE :in BOOLEAN; STOP_PROCESS :out BOOLEAN );
  procedure FOR_EACH_JSON_FIELD	( OF_OBJECT :ITEM );


  SYNTAX_ERROR, BAD_ITEM_TYPE, VALUE_NOT_FOUND	: exception;


--	1	2	3	4	5	6	7	8	9	0	1	2
-------------------------------------------------------------------------------------------------------------------------

										pragma PAGE;
private

  type ITEM_DEFINITION (KIND :JSON.ITEM_TYPE);
  type ITEM			is access ITEM_DEFINITION;

  type OBJECT_FIELD;
  type OBJECT_FIELD_ACCESS		is access OBJECT_FIELD;

  type ITEM_LIST_ELEMENT;
  type LIST_OF_ITEMS		is access ITEM_LIST_ELEMENT;

  type STRING_ACCESS		is access STRING;


  type ITEM_DEFINITION (KIND :ITEM_TYPE)	is record
				  case KIND is
				  when  OBJECT_ITEM		=> FIELDS_LIST	: OBJECT_FIELD_ACCESS;
				  when  ARRAY_ITEM		=> ITEMS_LIST	: LIST_OF_ITEMS;
				  when  STRING_ITEM		=> STR_ACCESS	: STRING_ACCESS;
				  when  INTEGER_ITEM	=> INT_VAL	: INTEGER;
				  when  FLOAT_ITEM		=> FLOAT_VAL	: LONG_FLOAT;
				  when  BOOLEAN_ITEM	=> BOOL_VAL	: BOOLEAN;
				  when  NULL_ITEM		=> null;
				  end case;
				end record;


  type OBJECT_FIELD			is record
				  FIELD_KEY	: STRING_ACCESS;
				  FIELD_ITEM	: ITEM;
				  NEXT		: OBJECT_FIELD_ACCESS;
				end record;


  type ITEM_LIST_ELEMENT		is record
				  LIST_ITEM	: ITEM;
				  NEXT		: LIST_OF_ITEMS;
				end record;

	----
end	JSON;
	----

--	1	2	3	4	5	6	7	8	9	0	1	2
-------------------------------------------------------------------------------------------------------------------------

The package body : JSON_bdy