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