Natools

Diff
Login

Differences From Artifact [b525d01f34]:

To Artifact [61b239fe3b]:


16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

with Natools.S_Expressions.Lockable.Tests;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Parsers.Tests is

   procedure Check_Parsing
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Parser : in Parsers.Parser;
      Input, Output : in Test_Tools.Memory_Stream);
      --  Report failure or success depending on Output seeing a mismatch
      --  or having pending data. Dump stream status if needed.

   generic
      Name : String;
      Source, Expected : Atom;
   procedure Blackbox_Test (Report : in out NT.Reporter'Class);
      --  Perform a simple blackbox test, feeding Source to a new parser
      --  plugged on a canonical printer and comparing with Expected.



   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Check_Parsing
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Parser : in Parsers.Parser;
      Input, Output : in Test_Tools.Memory_Stream) is
   begin
      if Parser.Current_Event = Events.Error
        or else Output.Has_Mismatch
        or else Output.Unread_Expected /= Null_Atom
      then
         Report.Item (Name, NT.Fail);

         if Parser.Current_Event = Events.Error then
            Report.Info ("Parser in error state");
         end if;

         if Output.Has_Mismatch then
            Report.Info ("Mismatch at position"
              & Count'Image (Output.Mismatch_Index));
            declare
               Output_Data : Atom renames Output.Get_Data;
            begin
               Report.Info ("Mismatching data: """
                 & To_String
                    (Output_Data (Output.Mismatch_Index .. Output_Data'Last))
                 & '"');
            end;
         end if;

         if Output.Unread_Expected /= Null_Atom then
            Report.Info ("Left to expect: """
              & To_String (Output.Unread_Expected) & '"');
         end if;

         Report.Info ("Remaining unread data: """
           & To_String (Input.Unread_Data) & '"');
         Report.Info ("Written data: """
           & To_String (Output.Get_Data) & '"');
      else
         Report.Item (Name, NT.Success);
      end if;
   end Check_Parsing;


   procedure Blackbox_Test (Report : in out NT.Reporter'Class) is
   begin
      declare
         Input, Output : aliased Test_Tools.Memory_Stream;
         Printer : Printers.Canonical (Output'Access);
         Parser : aliased Parsers.Parser;
         Sub : Subparser (Parser'Access, Input'Access);
      begin
         Output.Set_Expected (Expected);
         Input.Set_Data (Source);
         Sub.Next;

         Printers.Transfer (Sub, Printer);

         Check_Parsing (Report, Name, Parser, Input, Output);
      end;
   exception
      when Error : others => Report.Report_Exception (Name, Error);
   end Blackbox_Test;



   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Canonical_Encoding (Report);
      Atom_Encodings (Report);
      Base64_Subexpression (Report);
      Special_Subexpression (Report);
      Nested_Subpexression (Report);
      Number_Prefixes (Report);
      Quoted_Escapes (Report);
      Parser_Interface (Report);
      Subparser_Interface (Report);
      Lockable_Interface (Report);
   end All_Tests;



   -----------------------
   -- Inidividual Tests --







<
<
<
<
<
<
<
<













<
|
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




<
|



|
<
|
|
<


|

















<
<







16
17
18
19
20
21
22








23
24
25
26
27
28
29
30
31
32
33
34
35

36








37


































38
39
40
41

42
43
44
45
46

47
48

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68


69
70
71
72
73
74
75

with Natools.S_Expressions.Lockable.Tests;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Parsers.Tests is









   generic
      Name : String;
      Source, Expected : Atom;
   procedure Blackbox_Test (Report : in out NT.Reporter'Class);
      --  Perform a simple blackbox test, feeding Source to a new parser
      --  plugged on a canonical printer and comparing with Expected.



   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------


   procedure Blackbox_Test (Report : in out NT.Reporter'Class) is








      Test : NT.Test := Report.Item (Name);


































   begin
      declare
         Input, Output : aliased Test_Tools.Memory_Stream;
         Printer : Printers.Canonical (Output'Access);

         Parser : Parsers.Stream_Parser (Input'Access);
      begin
         Output.Set_Expected (Expected);
         Input.Set_Data (Source);
         Parser.Next;

         Printers.Transfer (Parser, Printer);
         Output.Check_Stream (Test);

      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Blackbox_Test;



   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Canonical_Encoding (Report);
      Atom_Encodings (Report);
      Base64_Subexpression (Report);
      Special_Subexpression (Report);
      Nested_Subpexression (Report);
      Number_Prefixes (Report);
      Quoted_Escapes (Report);


      Lockable_Interface (Report);
   end All_Tests;



   -----------------------
   -- Inidividual Tests --
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192


   procedure Lockable_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Lockable.Descriptor interface");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : aliased Parsers.Parser;
         Sub : Subparser (Parser'Access, Input'Access);
      begin
         Input.Set_Data (Lockable.Tests.Test_Expression);
         Test_Tools.Next_And_Check (Test, Sub, Events.Open_List, 1);
         Lockable.Tests.Test_Interface (Test, Sub);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Lockable_Interface;


   procedure Nested_Subpexression (Report : in out NT.Reporter'Class) is







<
|


|
|







117
118
119
120
121
122
123

124
125
126
127
128
129
130
131
132
133
134
135


   procedure Lockable_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Lockable.Descriptor interface");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;

         Parser : Parsers.Stream_Parser (Input'Access);
      begin
         Input.Set_Data (Lockable.Tests.Test_Expression);
         Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
         Lockable.Tests.Test_Interface (Test, Parser);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Lockable_Interface;


   procedure Nested_Subpexression (Report : in out NT.Reporter'Class) is
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
           & "(5:valid6:quoted11:hexadecimal7:base-647:expr-64)"
           & "(9:undefined2:423:10%3:123()2:10)"
           & "(7:invalid6:quoted11:hexadecimal7:base-647:expr-64)"));
   begin
      Test (Report);
   end Number_Prefixes;


   procedure Parser_Interface (Report : in out NT.Reporter'Class) is
      Name : constant String := "Parser interface";
      Source : constant Atom
        := To_Atom ("(5:first6:second)");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : Parsers.Parser;
      begin
         Input.Set_Data (Source);

         Parser.Next_Event (Input'Access);

         if Parser.Current_Event /= Events.Open_List then
            Report.Item (Name, NT.Fail);
            Report.Info ("Unexpected current event "
              & Events.Event'Image (Parser.Current_Event));
            return;
         end if;

         if Parser.Current_Level /= 1 then
            Report.Item (Name, NT.Fail);
            Report.Info ("Unexpected current level"
              & Integer'Image (Parser.Current_Level));
            return;
         end if;

         Parser.Next_Event (Input'Access);

         if Parser.Current_Event /= Events.Add_Atom then
            Report.Item (Name, NT.Fail);
            Report.Info ("Unexpected current event "
              & Events.Event'Image (Parser.Current_Event));
            return;
         end if;

         if Parser.Current_Atom /= To_Atom ("first") then
            Report.Item (Name, NT.Fail);
            Report.Info ("Unexpected current atom"
              & Integer'Image (Parser.Current_Atom'Length)
              & ":"
              & To_String (Parser.Current_Atom));
            return;
         end if;

         Parser.Next_Event (Input'Access);

         if Parser.Current_Event /= Events.Add_Atom then
            Report.Item (Name, NT.Fail);
            Report.Info ("Unexpected current event "
              & Events.Event'Image (Parser.Current_Event));
            return;
         end if;

         declare
            Buffer : Atom (50 .. 69);
            Length : Count;
         begin
            Parser.Read_Atom (Buffer, Length);
            if Length /= 6
              or else Buffer (Buffer'First .. Buffer'First + Length - 1)
                        /= To_Atom ("second")
            then
               Report.Item (Name, NT.Fail);
               Report.Info ("Unexpected read atom"
                 & Count'Image (Length)
                 & ":"
                 & To_String (Buffer
                     (Buffer'First .. Buffer'First + Length - 1)));
               return;
            end if;
         end;

         declare
            Buffer : Atom (11 .. 13);
            Length : Count;
         begin
            Parser.Read_Atom (Buffer, Length);
            if Length /= 6
              or else Buffer /= To_Atom ("sec")
            then
               Report.Item (Name, NT.Fail);
               Report.Info ("Unexpected read atom"
                 & Count'Image (Length)
                 & ":"
                 & To_String (Buffer));
               return;
            end if;
         end;

         Parser.Next_Event (Input'Access);

         if Parser.Current_Event /= Events.Close_List then
            Report.Item (Name, NT.Fail);
            Report.Info ("Unexpected current event "
              & Events.Event'Image (Parser.Current_Event));
            return;
         end if;

         begin
            declare
               Result : constant Atom := Parser.Current_Atom;
            begin
               Report.Item (Name, NT.Fail);
               Report.Info
                 ("Current_Atom raised no exception and returned"
                  & Integer'Image (Result'Length)
                  & ':'
                  & To_String (Result));
            end;
         exception
            when Program_Error => null;
            when Error : others =>
               Report.Report_Exception (Name & " (in Current_Event)", Error);
         end;

         declare
            Buffer : Atom (1 .. 10);
            Length : Count;
         begin
            Parser.Read_Atom (Buffer, Length);
            Report.Item (Name, NT.Fail);
            Report.Info
              ("Read_Atom raised no exception and returned"
               & Count'Image (Length)
               & ':'
               & To_String (Buffer));
         exception
            when Program_Error => null;
            when Error : others =>
               Report.Report_Exception (Name & " (in Read_Atom)", Error);
         end;

         declare
            Called : Boolean := False;
            Output : Test_Tools.Memory_Stream;

            procedure Process (Data : in Atom);

            procedure Process (Data : in Atom) is
            begin
               Called := True;
               Output.Set_Data (Data);
            end Process;
         begin
            Parser.Query_Atom (Process'Access);
            Report.Item (Name, NT.Fail);
            Report.Info ("Query_Atom raised no exception");
            if Called then
               Report.Info ("   Process was called with atom """
                 & To_String (Output.Get_Data) & '"');
            end if;
         exception
            when Program_Error => null;
            when Error : others =>
               Report.Report_Exception (Name & " (in Query_Event)", Error);
               if Called then
                  Report.Info ("   Process was called with atom """
                    & To_String (Output.Get_Data) & '"');
               end if;
         end;
      end;

      Report.Item (Name, NT.Success);
   exception
      when Error : others => Report.Report_Exception (Name, Error);
   end Parser_Interface;


   procedure Quoted_Escapes (Report : in out NT.Reporter'Class) is
      CR : constant Character := Character'Val (13);
      LF : constant Character := Character'Val (10);

      procedure Test is new Blackbox_Test
        (Name => "Escapes in quoted encoding",







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







159
160
161
162
163
164
165









































































































































































166
167
168
169
170
171
172
           & "(5:valid6:quoted11:hexadecimal7:base-647:expr-64)"
           & "(9:undefined2:423:10%3:123()2:10)"
           & "(7:invalid6:quoted11:hexadecimal7:base-647:expr-64)"));
   begin
      Test (Report);
   end Number_Prefixes;











































































































































































   procedure Quoted_Escapes (Report : in out NT.Reporter'Class) is
      CR : constant Character := Character'Val (13);
      LF : constant Character := Character'Val (10);

      procedure Test is new Blackbox_Test
        (Name => "Escapes in quoted encoding",
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
           & "10:hidden-end)(12:hidden-begin"
           & "3:end)"
           & "(16:overflowing atom)"));
   begin
      Test (Report);
   end Special_Subexpression;


   procedure Subparser_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Subparser interface");
      Source : constant Atom
        := To_Atom ("(begin(command arg1 (subarg1 subarg2) arg3)end)");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : aliased Parsers.Parser;
         Sub : Subparser (Parser'Access, Input'Access);
         Event : Events.Event;
      begin
         Input.Set_Data (Source);

         --  Read header

         Parser.Next_Event (Input'Access);
         pragma Assert (Parser.Current_Event = Events.Open_List);
         Parser.Next_Event (Input'Access);
         pragma Assert (Parser.Current_Event = Events.Add_Atom
           and then Parser.Current_Atom = To_Atom ("begin"));
         Parser.Next_Event (Input'Access);
         pragma Assert (Parser.Current_Event = Events.Open_List);
         Parser.Next_Event (Input'Access);
         pragma Assert (Parser.Current_Event = Events.Add_Atom
           and then Parser.Current_Atom = To_Atom ("command"));

         --  Use subparser as command arguments

         Test_Tools.Next_And_Check (Test, Sub, To_Atom ("arg1"), 0);
         Test_Tools.Next_And_Check (Test, Sub, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Sub, To_Atom ("subarg1"), 1);
         Test_Tools.Next_And_Check (Test, Sub, To_Atom ("subarg2"), 1);

         Sub.Finish;

         --  Check final state of parser

         if Parser.Current_Event /= Events.Close_List then
            Test.Fail ("Unexpected parser final state: "
              & Events.Event'Image (Parser.Current_Event));
         end if;

         if Parser.Current_Level /= 1 then
            Test.Fail ("Unexpected parser final level:"
              & Natural'Image (Parser.Current_Level));
         end if;

         Parser.Next_Event (Input'Access);

         if Parser.Current_Event /= Events.Add_Atom then
            Test.Fail ("Unexpected parser penultimate state: "
              & Events.Event'Image (Parser.Current_Event));
         end if;

         if Parser.Current_Atom /= To_Atom ("end") then
            Test.Fail;
            Test_Tools.Dump_Atom (Test, Parser.Current_Atom,
              "Parser last atom");
         end if;

         --  Check subparser error states

         if Sub.Current_Event /= Events.End_Of_Input then
            Test.Fail ("Unexpected subparser final state: "
              & Events.Event'Image (Sub.Current_Event));
         end if;

         if Sub.Current_Level /= 0 then
            Test.Fail ("Unexpected subparser final level:"
              & Natural'Image (Sub.Current_Level));
         end if;

         begin
            declare
               Buffer : constant Atom := Sub.Current_Atom;
            begin
               Test.Fail
                 ("No exception raised in Current_Atom on finished subparser");
               Test_Tools.Dump_Atom (Test, Buffer);
            end;
            return;
         exception
            when Program_Error => null;
            when Error : others =>
               Test.Report_Exception (Error);
               Test.Info ("in Current_Atom");
         end;

         declare
            Buffer : Atom (1 .. 100);
            Length : Count := 0;
         begin
            Sub.Read_Atom (Buffer, Length);
            Test.Fail
              ("No exception raised in Read_Atom on finished subparser");
            Test_Tools.Dump_Atom (Test, Buffer (1 .. Length));
            return;
         exception
            when Program_Error => null;
            when Error : others =>
               Test.Report_Exception (Error);
               Test.Info ("in Read_Atom");
               Test_Tools.Dump_Atom (Test, Buffer (1 .. Length), "Buffer");
               return;
         end;

         declare
            Called : Boolean := False;
            Output : Test_Tools.Memory_Stream;

            procedure Process (Data : in Atom);

            procedure Process (Data : in Atom) is
            begin
               Called := True;
               Output.Set_Data (Data);
            end Process;
         begin
            Sub.Query_Atom (Process'Access);
            Test.Fail
              ("No exception raised in Query_Atom on finished subparser");
            if Called then
               Test_Tools.Dump_Atom (Test, Output.Get_Data,
                 "Process called with");
            end if;
         exception
            when Program_Error => null;
            when Error : others =>
               Test.Report_Exception (Error);
               Test.Info ("in Query_Event");
               if Called then
                  Test_Tools.Dump_Atom (Test, Output.Get_Data,
                    "Process called with");
               end if;
         end;

         begin
            Sub.Next (Event);
            Test.Fail ("No exception raised in Next on finished subparser");
            Test.Info ("   returned event: " & Events.Event'Image (Event));
         exception
            when Constraint_Error => null;
            when Error : others =>
               Test.Report_Exception (Error);
               Test.Info ("in Next");
         end;

         --  Check that above subparser calls have not tampered with Parser

         if Parser.Current_Event /= Events.Add_Atom
           or else Parser.Current_Level /= 1
           or else Parser.Current_Atom /= To_Atom ("end")
         then
            Test.Fail ("Parser state changed after calling methods on "
              & "finished subparser");
            return;
         end if;
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Subparser_Interface;

end Natools.S_Expressions.Parsers.Tests;







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

201
202
203
204
205
206
207



































































































































































208
           & "10:hidden-end)(12:hidden-begin"
           & "3:end)"
           & "(16:overflowing atom)"));
   begin
      Test (Report);
   end Special_Subexpression;




































































































































































end Natools.S_Expressions.Parsers.Tests;