1--
2-- Copyright (c) 2007-2011 Tero Koskinen <tero.koskinen@iki.fi>
3--
4-- Permission to use, copy, modify, and distribute this software for any
5-- purpose with or without fee is hereby granted, provided that the above
6-- copyright notice and this permission notice appear in all copies.
7--
8-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15--
16
17with Ada.Strings;
18with Ada.Unchecked_Deallocation;
19with Ada.Exceptions;
20with Ahven.Long_AStrings;
21with Util.Measures;
22with Util.Log.Loggers;
23
24package body Ahven.Framework is
25   use Ahven.AStrings;
26
27   -- A few local procedures, so we do not need to duplicate code.
28   procedure Free_Test is
29      new Ada.Unchecked_Deallocation (Object => Test'Class,
30                                      Name   => Test_Class_Access);
31
32   generic
33      with procedure Action is <>;
34   procedure Execute_Internal
35     (Test_Object     : in out Test'Class;
36      Listener_Object : in out Listeners.Result_Listener'Class);
37   -- Logic for Execute procedures. Action is specified by the caller.
38
39   procedure Set_Up (T : in out Test) is
40   begin
41      null; -- empty by default
42   end Set_Up;
43
44   procedure Tear_Down (T : in out Test) is
45   begin
46      null; -- empty by default
47   end Tear_Down;
48
49   procedure Run (T         : in out Test;
50                  Listener  : in out Listeners.Result_Listener'Class) is
51   begin
52      Run (T => Test'Class (T), Listener => Listener, Timeout => 0.0);
53   end Run;
54
55   procedure Run (T         : in out Test;
56                  Test_Name :        String;
57                  Listener  : in out Listeners.Result_Listener'Class) is
58   begin
59      Run (T         => Test'Class (T),
60           Test_Name => Test_Name,
61           Listener  => Listener,
62           Timeout   => 0.0);
63   end Run;
64
65   procedure Execute_Internal
66     (Test_Object     : in out Test'Class;
67      Listener_Object : in out Listeners.Result_Listener'Class)
68   is
69      use Ahven.Listeners;
70   begin
71      -- This Start_Test here is called for Test_Suites and Test_Cases.
72      -- Info includes only the name of the test suite/case.
73      --
74      -- There is a separate Start_Test/End_Test pair for test routines
75      -- in the Run (T : in out Test_Case; ...) procedure.
76      Listeners.Start_Test
77        (Listener_Object,
78         (Phase     => TEST_BEGIN,
79          Test_Name => To_Bounded_String (Get_Name (Test_Object)),
80          Test_Kind => CONTAINER));
81
82      Action;
83
84      -- Like Start_Test, only for Test_Suites and Test_Cases.
85      Listeners.End_Test
86        (Listener_Object,
87         (Phase     => TEST_END,
88          Test_Name => To_Bounded_String (Get_Name (Test_Object)),
89          Test_Kind => CONTAINER));
90   end Execute_Internal;
91
92   procedure Execute (T        : in out Test'Class;
93                      Listener : in out Listeners.Result_Listener'Class;
94                      Timeout  :        Test_Duration) is
95      procedure Run_Impl is
96      begin
97         Run (T, Listener, Timeout);
98      end Run_Impl;
99
100      procedure Execute_Impl is new Execute_Internal (Action => Run_Impl);
101   begin
102      Execute_Impl (Test_Object => T, Listener_Object => Listener);
103   end Execute;
104
105   procedure Execute (T           : in out Test'Class;
106                      Test_Name   :        String;
107                      Listener    : in out Listeners.Result_Listener'Class;
108                      Timeout     :        Test_Duration) is
109      procedure Run_Impl is
110      begin
111         Run (T         => T,
112              Test_Name => Test_Name,
113              Listener  => Listener,
114              Timeout   => Timeout);
115      end Run_Impl;
116
117      procedure Execute_Impl is new Execute_Internal (Action => Run_Impl);
118   begin
119      Execute_Impl (Test_Object => T, Listener_Object => Listener);
120   end Execute;
121
122
123   ----------- Test_Case ------------------------------
124
125
126   -- Wrap an "object" routine inside a Test_Command record
127   -- and add it to the test command list.
128   --
129   -- Name of the test will be silently cut if it does not
130   -- fit completely into AStrings.Bounded_String.
131   procedure Add_Test_Routine (T       : in out Test_Case'Class;
132                               Routine :        Object_Test_Routine_Access;
133                               Name    :        String)
134   is
135      Command : constant Test_Command :=
136        (Command_Kind   => OBJECT,
137         Name           => To_Bounded_String
138                             (Source => Name,
139                              Drop   => Ada.Strings.Right),
140         Object_Routine => Routine);
141   begin
142      Test_Command_List.Append (T.Routines, Command);
143   end Add_Test_Routine;
144
145   -- Wrap a "simple" routine inside a Test_Command record
146   -- and add it to the test command list.
147   --
148   -- Name of the test will be silently cut if it does not
149   -- fit completely into AStrings.Bounded_String.
150   procedure Add_Test_Routine (T       : in out Test_Case'Class;
151                               Routine :        Simple_Test_Routine_Access;
152                               Name    :        String)
153   is
154      Command : constant Test_Command :=
155        (Command_Kind   => SIMPLE,
156         Name           => To_Bounded_String
157                             (Source => Name,
158                              Drop   => Ada.Strings.Right),
159         Simple_Routine => Routine);
160   begin
161      Test_Command_List.Append (T.Routines, Command);
162   end Add_Test_Routine;
163
164   -- The heart of the package.
165   -- Run one test routine (well, Command at this point) and
166   -- notify listeners about the result.
167   procedure Run_Command (Command  :        Test_Command;
168                          Info     :        Listeners.Context;
169                          Timeout  :        Test_Duration;
170                          Listener : in out Listeners.Result_Listener'Class;
171                          T        : in out Test_Case'Class) is
172      use Ahven.Listeners;
173      use Ahven.Long_AStrings;
174
175      type Test_Status is
176        (TEST_PASS, TEST_FAIL, TEST_ERROR, TEST_TIMEOUT, TEST_SKIP);
177
178      protected type Test_Results is
179         function Get_Status return Test_Status;
180         procedure Set_Status (Value : Test_Status);
181
182         function Get_Message return AStrings.Bounded_String;
183         procedure Set_Message (Value : AStrings.Bounded_String);
184
185         function Get_Long_Message return Long_AStrings.Bounded_String;
186         procedure Set_Long_Message (Value : Long_AStrings.Bounded_String);
187      private
188         Status : Test_Status := TEST_ERROR;
189         Message : AStrings.Bounded_String;
190         Long_Message : Long_AStrings.Bounded_String;
191      end Test_Results;
192
193      protected body Test_Results is
194         function Get_Status return Test_Status is
195         begin
196            return Status;
197         end Get_Status;
198
199         procedure Set_Status (Value : Test_Status) is
200         begin
201            Status := Value;
202         end Set_Status;
203
204         function Get_Message return AStrings.Bounded_String is
205         begin
206            return Message;
207         end Get_Message;
208
209         procedure Set_Message (Value : AStrings.Bounded_String) is
210         begin
211            Message := Value;
212         end Set_Message;
213
214         function Get_Long_Message return Long_AStrings.Bounded_String is
215         begin
216            return Long_Message;
217         end Get_Long_Message;
218
219         procedure Set_Long_Message (Value : Long_AStrings.Bounded_String) is
220         begin
221            Long_Message := Value;
222         end Set_Long_Message;
223      end Test_Results;
224
225      Result : Test_Results;
226
227      --  In order to collect all the performance measures in a same set, use the same
228      --  measure set on the test running task and on the main task.  This allows us to
229      --  save all the measures together in an XML result file at the end.
230      Perf   : constant Util.Measures.Measure_Set_Access := Util.Measures.Get_Current;
231
232      task type Command_Task is
233         entry Start_Command;
234         entry End_Command;
235      end Command_Task;
236
237      procedure Run_A_Command is
238         procedure Set_Status (S            :        Test_Status;
239                               Message      :        String;
240                               Long_Message :        String;
241                               R            : in out Test_Results)
242         is
243         begin
244            R.Set_Status (S);
245            R.Set_Message (To_Bounded_String
246              (Source => Message,
247               Drop   => Ada.Strings.Right));
248            R.Set_Long_Message (To_Bounded_String
249              (Source => Long_Message,
250               Drop   => Ada.Strings.Right));
251         end Set_Status;
252      begin
253         Util.Measures.Set_Current (Perf);
254         begin
255            Run (Command, T);
256            Result.Set_Status (TEST_PASS);
257         exception
258            when E : Assertion_Error =>
259               Set_Status
260                 (S            => TEST_FAIL,
261                  Message      => Ada.Exceptions.Exception_Message (E),
262                  Long_Message => Util.Log.Loggers.Traceback (E),
263                  R            => Result);
264            when E : Test_Skipped_Error =>
265               Set_Status
266                 (S            => TEST_SKIP,
267                  Message      => Ada.Exceptions.Exception_Message (E),
268                  Long_Message => Util.Log.Loggers.Traceback (E),
269                  R            => Result);
270            when E : others =>
271               Set_Status
272                 (S            => TEST_ERROR,
273                  Message      => Ada.Exceptions.Exception_Message (E),
274                  Long_Message => Util.Log.Loggers.Traceback (E),
275                  R            => Result);
276         end;
277      end Run_A_Command;
278
279      task body Command_Task is
280      begin
281         accept Start_Command;
282         Run_A_Command;
283         accept End_Command;
284      end Command_Task;
285
286      Status : Test_Status;
287
288   begin
289      if Timeout > 0.0 then
290         declare
291            Command_Runner : Command_Task;
292         begin
293            Command_Runner.Start_Command;
294            select
295               Command_Runner.End_Command;
296            or
297               delay Duration (Timeout);
298               abort Command_Runner;
299               Result.Set_Status (Test_Timeout);
300            end select;
301         end;
302      else
303         Run_A_Command;
304      end if;
305      Status := Result.Get_Status;
306
307      case Status is
308         when TEST_PASS =>
309            Listeners.Add_Pass (Listener, Info);
310         when TEST_FAIL =>
311            Listeners.Add_Failure
312              (Listener,
313               (Phase        => TEST_RUN,
314                Test_Name    => Info.Test_Name,
315                Test_Kind    => CONTAINER,
316                Routine_Name => Info.Routine_Name,
317                Message      => Result.Get_Message,
318                Long_Message => Long_AStrings.Null_Bounded_String));
319         when TEST_ERROR =>
320            Listeners.Add_Error
321              (Listener,
322               (Phase        => Listeners.TEST_RUN,
323                Test_Name    => Info.Test_Name,
324                Test_Kind    => CONTAINER,
325                Routine_Name => Info.Routine_Name,
326                Message      => Result.Get_Message,
327                Long_Message => Result.Get_Long_Message));
328         when TEST_TIMEOUT =>
329            Listeners.Add_Error
330              (Listener,
331               (Phase        => Listeners.TEST_RUN,
332                Test_Name    => Info.Test_Name,
333                Test_Kind    => CONTAINER,
334                Routine_Name => Info.Routine_Name,
335                Message      => To_Bounded_String ("TIMEOUT"),
336                Long_Message => Long_AStrings.Null_Bounded_String));
337         when TEST_SKIP =>
338            Listeners.Add_Skipped
339              (Listener,
340               (Phase        => TEST_RUN,
341                Test_Name    => Info.Test_Name,
342                Test_Kind    => CONTAINER,
343                Routine_Name => Info.Routine_Name,
344                Message      => Result.Get_Message,
345                Long_Message => Long_AStrings.Null_Bounded_String));
346      end case;
347   end Run_Command;
348
349   function Get_Name (T : Test_Case) return String is
350   begin
351      return To_String (T.Name);
352   end Get_Name;
353
354   procedure Run_Internal
355     (T            : in out Test_Case;
356      Listener     : in out Listeners.Result_Listener'Class;
357      Command      :        Test_Command;
358      Test_Name    :        String;
359      Routine_Name :        String;
360      Timeout      :        Test_Duration)
361   is
362      use Ahven.Listeners;
363   begin
364      Listeners.Start_Test
365        (Listener,
366         (Phase     => Ahven.Listeners.TEST_BEGIN,
367          Test_Name => To_Bounded_String (Test_Name),
368          Test_Kind => ROUTINE));
369      Run_Command (Command  => Command,
370                   Info     =>
371                     (Phase        => Listeners.TEST_RUN,
372                      Test_Name    => To_Bounded_String (Test_Name),
373                      Test_Kind    => ROUTINE,
374                      Routine_Name =>
375                        To_Bounded_String (Routine_Name),
376                      Message      => AStrings.Null_Bounded_String,
377                      Long_Message => Long_AStrings.Null_Bounded_String),
378                   Timeout  => Timeout,
379                   Listener => Listener,
380                   T        => T);
381      Listeners.End_Test
382        (Listener,
383         (Phase          => Ahven.Listeners.TEST_END,
384          Test_Name      => To_Bounded_String (Test_Name),
385          Test_Kind      => ROUTINE));
386   end Run_Internal;
387
388   -- Run procedure for Test_Case.
389   --
390   -- Loops over the test routine list and executes the routines.
391   procedure Run (T        : in out Test_Case;
392                  Listener : in out Listeners.Result_Listener'Class;
393                  Timeout  :        Test_Duration)
394   is
395      procedure Exec (Cmd : in out Test_Command) is
396      begin
397         Run_Internal (T            => T,
398                       Listener     => Listener,
399                       Command      => Cmd,
400                       Timeout      => Timeout,
401                       Test_Name    => Get_Name (T),
402                       Routine_Name => To_String (Cmd.Name));
403      end Exec;
404
405      procedure Run_All is new Test_Command_List.For_Each
406        (Action => Exec);
407   begin
408      Run_All (T.Routines);
409   end Run;
410
411   -- Purpose of the procedure is to run all
412   -- test routines with name Test_Name.
413   procedure Run (T         : in out Test_Case;
414                  Test_Name :        String;
415                  Listener  : in out Listeners.Result_Listener'Class;
416                  Timeout   :        Test_Duration)
417   is
418      procedure Exec (Cmd : in out Test_Command) is
419      begin
420         if To_String (Cmd.Name) = Test_Name then
421            Run_Internal (T            => T,
422                          Listener     => Listener,
423                          Command      => Cmd,
424                          Timeout      => Timeout,
425                          Test_Name    => Get_Name (T),
426                          Routine_Name => To_String (Cmd.Name));
427         end if;
428      end Exec;
429
430      procedure Run_All is new Test_Command_List.For_Each (Action => Exec);
431   begin
432      Run_All (T.Routines);
433   end Run;
434
435   function Test_Count (T : Test_Case) return Test_Count_Type is
436   begin
437      return Test_Count_Type (Test_Command_List.Length (T.Routines));
438   end Test_Count;
439
440   function Test_Count (T : Test_Case; Test_Name : String)
441     return Test_Count_Type
442   is
443      use Test_Command_List;
444
445      Counter  : Test_Count_Type := 0;
446
447      procedure Increase (Cmd : in out Test_Command) is
448      begin
449         if To_String (Cmd.Name) = Test_Name then
450            Counter := Counter + 1;
451         end if;
452      end Increase;
453
454      procedure Count_Commands is new
455        Test_Command_List.For_Each (Action => Increase);
456   begin
457      Count_Commands (T.Routines);
458
459      return Counter;
460   end Test_Count;
461
462   procedure Finalize (T : in out Test_Case) is
463   begin
464      Test_Command_List.Clear (T.Routines);
465   end Finalize;
466
467   procedure Set_Name (T : in out Test_Case; Name : String) is
468   begin
469      T.Name := To_Bounded_String (Source => Name, Drop => Ada.Strings.Right);
470   end Set_Name;
471
472
473   ----------- Test_Suite -----------------------------
474
475
476   function Create_Suite (Suite_Name : String)
477     return Test_Suite_Access is
478   begin
479      return
480        new Test_Suite'
481          (Ada.Finalization.Controlled with
482           Suite_Name        => To_Bounded_String
483                                  (Source => Suite_Name,
484                                   Drop   => Ada.Strings.Right),
485           Test_Cases        => Test_List.Empty_List,
486           Static_Test_Cases => Indefinite_Test_List.Empty_List);
487   end Create_Suite;
488
489   function Create_Suite (Suite_Name : String)
490     return Test_Suite is
491   begin
492      return (Ada.Finalization.Controlled with
493              Suite_Name        => To_Bounded_String
494                                     (Source => Suite_Name,
495                                      Drop   => Ada.Strings.Right),
496              Test_Cases        => Test_List.Empty_List,
497              Static_Test_Cases => Indefinite_Test_List.Empty_List);
498   end Create_Suite;
499
500   procedure Add_Test (Suite : in out Test_Suite; T : Test_Class_Access) is
501   begin
502      Test_List.Append (Suite.Test_Cases, (Ptr => T));
503   end Add_Test;
504
505   procedure Add_Test (Suite : in out Test_Suite; T : Test_Suite_Access) is
506   begin
507      Add_Test (Suite, Test_Class_Access (T));
508   end Add_Test;
509
510   procedure Add_Static_Test
511     (Suite : in out Test_Suite; T : Test'Class) is
512   begin
513      Indefinite_Test_List.Append (Suite.Static_Test_Cases, T);
514   end Add_Static_Test;
515
516   function Get_Name (T : Test_Suite) return String is
517   begin
518      return To_String (T.Suite_Name);
519   end Get_Name;
520
521   procedure Run (T        : in out Test_Suite;
522                  Listener : in out Listeners.Result_Listener'Class;
523                  Timeout  :        Test_Duration)
524   is
525      -- Some nested procedure exercises here.
526      --
527      -- Execute_Cases is for normal test list
528      -- and Execute_Static_Cases is for indefinite test list.
529      --
530      -- Normal test list does not have For_Each procedure,
531      -- so we need to loop manually.
532
533      -- A helper procedure which runs Execute for the given test.
534      procedure Execute_Test (Current : in out Test'Class) is
535      begin
536         Execute (Current, Listener, Timeout);
537      end Execute_Test;
538
539      procedure Execute_Test_Ptr (Current : in out Test_Class_Wrapper) is
540      begin
541         Execute (Current.Ptr.all, Listener, Timeout);
542      end Execute_Test_Ptr;
543
544      procedure Execute_Static_Cases is
545        new Indefinite_Test_List.For_Each (Action => Execute_Test);
546      procedure Execute_Cases is
547        new Test_List.For_Each (Action => Execute_Test_Ptr);
548   begin
549      Execute_Cases (T.Test_Cases);
550      Execute_Static_Cases (T.Static_Test_Cases);
551   end Run;
552
553   procedure Run (T         : in out Test_Suite;
554                  Test_Name :        String;
555                  Listener  : in out Listeners.Result_Listener'Class;
556                  Timeout   :        Test_Duration)
557   is
558      procedure Execute_Test (Current : in out Test'Class) is
559      begin
560         if Get_Name (Current) = Test_Name then
561            Execute (T => Current, Listener => Listener, Timeout => Timeout);
562         else
563            Execute (T         => Current,
564                     Test_Name => Test_Name,
565                     Listener  => Listener,
566                     Timeout   => Timeout);
567         end if;
568      end Execute_Test;
569
570      procedure Execute_Test_Ptr (Current : in out Test_Class_Wrapper) is
571      begin
572         Execute_Test (Current.Ptr.all);
573      end Execute_Test_Ptr;
574
575      procedure Execute_Cases is
576        new Test_List.For_Each (Action => Execute_Test_Ptr);
577
578      procedure Execute_Static_Cases is
579        new Indefinite_Test_List.For_Each (Action => Execute_Test);
580   begin
581      if Test_Name = To_String (T.Suite_Name) then
582         Run (T, Listener, Timeout);
583      else
584         Execute_Cases (T.Test_Cases);
585         Execute_Static_Cases (T.Static_Test_Cases);
586      end if;
587   end Run;
588
589   function Test_Count (T : Test_Suite) return Test_Count_Type is
590      Counter : Test_Count_Type := 0;
591
592      procedure Inc_Counter (Test_Obj : in out Test'Class) is
593      begin
594         Counter := Counter + Test_Count (Test_Obj);
595      end Inc_Counter;
596
597      procedure Inc_Counter_Ptr (Wrapper : in out Test_Class_Wrapper) is
598      begin
599         Inc_Counter (Wrapper.Ptr.all);
600      end Inc_Counter_Ptr;
601   begin
602      declare
603         use Test_List;
604         procedure Count_All is new For_Each (Action => Inc_Counter_Ptr);
605      begin
606         Count_All (T.Test_Cases);
607      end;
608
609      declare
610         use Indefinite_Test_List;
611         procedure Count_All is new For_Each (Action => Inc_Counter);
612      begin
613         Count_All (T.Static_Test_Cases);
614      end;
615
616      return Counter;
617   end Test_Count;
618
619   function Test_Count (T : Test_Suite; Test_Name : String)
620     return Test_Count_Type is
621      Counter : Test_Count_Type := 0;
622
623      procedure Handle_Test (Test_Object : in out Test'Class) is
624      begin
625         if Get_Name (Test_Object) = Test_Name then
626            Counter := Counter + Test_Count (Test_Object);
627         else
628            Counter := Counter + Test_Count (Test_Object, Test_Name);
629         end if;
630      end Handle_Test;
631
632      procedure Handle_Test_Ptr (Obj : in out Test_Class_Wrapper) is
633      begin
634         Handle_Test (Obj.Ptr.all);
635      end Handle_Test_Ptr;
636
637      procedure Count_Static is
638        new Indefinite_Test_List.For_Each (Action => Handle_Test);
639      procedure Count_Tests is
640        new Test_List.For_Each (Action => Handle_Test_Ptr);
641   begin
642      if Test_Name = To_String (T.Suite_Name) then
643         return Test_Count (T);
644      end if;
645
646      Count_Tests (T.Test_Cases);
647      Count_Static (T.Static_Test_Cases);
648
649      return Counter;
650   end Test_Count;
651
652   procedure Adjust (T : in out Test_Suite) is
653      use Test_List;
654
655      New_List : List := Empty_List;
656
657      procedure Create_Copy (Item : in out Test_Class_Wrapper) is
658      begin
659         Append (New_List, (Ptr => new Test'Class'(Item.Ptr.all)));
660      end Create_Copy;
661
662      procedure Copy_All is new For_Each (Action => Create_Copy);
663   begin
664      Copy_All (T.Test_Cases);
665
666      T.Test_Cases := New_List;
667   end Adjust;
668
669   procedure Finalize  (T : in out Test_Suite) is
670      use Test_List;
671
672      procedure Free_Item (Item : in out Test_Class_Wrapper) is
673      begin
674         Free_Test (Item.Ptr);
675      end Free_Item;
676
677      procedure Free_All is new For_Each (Action => Free_Item);
678
679   begin
680      Free_All (T.Test_Cases);
681      Clear (T.Test_Cases);
682   end Finalize;
683
684   procedure Release_Suite (T : Test_Suite_Access) is
685      procedure Free is
686        new Ada.Unchecked_Deallocation (Object => Test_Suite,
687                                        Name   => Test_Suite_Access);
688      Ptr : Test_Suite_Access := T;
689   begin
690      Free (Ptr);
691   end Release_Suite;
692
693   procedure Run (Command : Test_Command; T : in out Test_Case'Class) is
694   begin
695      case Command.Command_Kind is
696         when SIMPLE =>
697            Command.Simple_Routine.all;
698         when OBJECT =>
699            Set_Up (T);
700            begin
701               Command.Object_Routine.all (T);
702            exception
703               when others =>
704                  --  Make sure Tear_Down is called even if the test failed.
705                  Tear_Down (T);
706                  raise;
707            end;
708            Tear_Down (T);
709      end case;
710   end Run;
711
712
713   ----------- Indefinite_Test_List -------------------
714
715
716   package body Indefinite_Test_List is
717      procedure Remove (Ptr : Node_Access) is
718         procedure Free is
719           new Ada.Unchecked_Deallocation (Object => Node,
720                                           Name   => Node_Access);
721         My_Ptr : Node_Access := Ptr;
722      begin
723         Ptr.Next := null;
724         Free_Test (My_Ptr.Data);
725         My_Ptr.Data := null;
726         Free (My_Ptr);
727      end Remove;
728
729      procedure Append (Target : in out List;
730                        Node_Data : Test'Class) is
731         New_Node : Node_Access  := null;
732      begin
733         New_Node := new Node'(Data => new Test'Class'(Node_Data),
734                               Next => null);
735
736         if Target.Last = null then
737            Target.Last := New_Node;
738            Target.First := New_Node;
739         else
740            Target.Last.Next := New_Node;
741            Target.Last := New_Node;
742         end if;
743      end Append;
744
745      procedure Clear (Target : in out List) is
746         Current_Node : Node_Access := Target.First;
747         Next_Node : Node_Access := null;
748      begin
749         while Current_Node /= null loop
750            Next_Node := Current_Node.Next;
751            Remove (Current_Node);
752            Current_Node := Next_Node;
753         end loop;
754
755         Target.First := null;
756         Target.Last := null;
757      end Clear;
758
759      procedure For_Each (Target : List) is
760         Current_Node : Node_Access := Target.First;
761      begin
762         while Current_Node /= null loop
763            Action (Current_Node.Data.all);
764            Current_Node := Current_Node.Next;
765         end loop;
766      end For_Each;
767
768      procedure Initialize (Target : in out List) is
769      begin
770         Target.Last := null;
771         Target.First := null;
772      end Initialize;
773
774      procedure Finalize (Target : in out List) is
775      begin
776         Clear (Target);
777      end Finalize;
778
779      procedure Adjust (Target : in out List) is
780         Target_Last : Node_Access := null;
781         Target_First : Node_Access := null;
782         Current : Node_Access := Target.First;
783         New_Node : Node_Access;
784      begin
785         while Current /= null loop
786            New_Node := new Node'(Data => new Test'Class'(Current.Data.all),
787                                  Next => null);
788
789            if Target_Last = null then
790               Target_First := New_Node;
791            else
792               Target_Last.Next := New_Node;
793            end if;
794            Target_Last := New_Node;
795
796            Current := Current.Next;
797         end loop;
798         Target.First := Target_First;
799         Target.Last := Target_Last;
800      end Adjust;
801   end Indefinite_Test_List;
802end Ahven.Framework;
803