-- 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;-- 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 : <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>