-- CXACC01.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained -- unlimited rights in the software and documentation contained herein. -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making -- this public release, the Government intends to confer upon all -- recipients unlimited rights equal to those held by the Government. -- These rights include rights to use, duplicate, release or disclose the -- released technical data and computer software in whole or in part, in -- any manner and for any purpose whatsoever, and to have or permit others -- to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- OBJECTIVE: -- Check that the use of 'Class'Output and 'Class'Input allow stream -- manipulation of objects of non-limited class-wide types. -- -- TEST DESCRIPTION: -- This test demonstrates the uses of 'Class'Output and 'Class'Input -- in moving objects of a particular class to and from a stream file. -- A procedure uses a class-wide parameter to move objects of specific -- types in the class to the stream, using the 'Class'Output attribute -- of the root type of the class. A function returns a class-wide object, -- using the 'Class'Input attribute of the root type of the class to -- extract the object from the stream. -- A field-by-field comparison of record objects is performed to validate -- the data read from the stream. Operator precedence rules are used -- in the comparison rather than parentheses. -- -- APPLICABILITY CRITERIA: -- This test is applicable to all implementations capable of supporting -- external Stream_IO files. -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1. -- 24 Aug 96 SAIC Changed a call to "Create" to "Reset". -- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. --! with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report; procedure CXACC01 is Order_File : Ada.Streams.Stream_IO.File_Type; Order_Stream : Ada.Streams.Stream_IO.Stream_Access; Order_Filename : constant String := Report.Legal_File_Name ( Nam => "CXACC01" ); Incomplete : exception; begin Report.Test ("CXACC01", "Check that the use of 'Class'Output " & "and 'Class'Input allow stream manipulation " & "of objects of non-limited class-wide types"); Test_for_Stream_IO_Support: begin -- If an implementation does not support Stream_IO in a particular -- environment, the exception Use_Error or Name_Error will be raised on -- calls to various Stream_IO operations. This block statement -- encloses a call to Create, which should produce an exception in a -- non-supportive environment. These exceptions will be handled to -- produce a Not_Applicable result. Ada.Streams.Stream_IO.Create (Order_File, Ada.Streams.Stream_IO.Out_File, Order_Filename); exception when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => Report.Not_Applicable ( "Files not supported - Create as Out_File for Stream_IO" ); raise Incomplete; end Test_for_Stream_IO_Support; Operational_Test_Block: declare -- Store tag values associated with objects of tagged types. TC_Box_Office_Tag : constant String := Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag); TC_Summer_Tag : constant String := Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag); TC_Mayoral_Tag : constant String := Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag); TC_Late_Tag : constant String := Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag); -- The following procedure will take an object of the Ticket_Request -- class and output it to the stream. Objects of any extended type -- in the class can be output to the stream with this procedure. procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is begin FXACC00.Ticket_Request'Class'Output (Order_Stream, Order); end Order_Entry; -- The following function will retrieve from the stream an object of -- the Ticket_Request class. function Order_Retrieval return FXACC00.Ticket_Request'Class is begin return FXACC00.Ticket_Request'Class'Input (Order_Stream); end Order_Retrieval; begin Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File); -- Store the data objects in the stream. -- Each of the objects is of a different type within the class. Order_Entry (FXACC00.Box_Office_Request); -- Object of root type Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type Order_Entry (FXACC00.Late_Request); -- Object of twice -- extended type. -- Reset mode of stream to In_File prior to reading data from it. Reset1: begin Ada.Streams.Stream_IO.Reset (Order_File, Ada.Streams.Stream_IO.In_File); exception when Ada.Streams.Stream_IO.Use_Error => Report.Not_Applicable ( "Reset to In_File not supported for Stream_IO - 1" ); raise Incomplete; end Reset1; Process_Order_Block: declare use FXACC00; -- Declare variables of the root type class, -- and initialize them with class-wide objects returned from -- the stream as function result. Order_1 : Ticket_Request'Class := Order_Retrieval; Order_2 : Ticket_Request'Class := Order_Retrieval; Order_3 : Ticket_Request'Class := Order_Retrieval; Order_4 : Ticket_Request'Class := Order_Retrieval; -- Declare objects of the specific types from within the class -- that correspond to the types of the data written to the -- stream. Perform a type conversion on the class-wide objects. Ticket_Order : Ticket_Request := Ticket_Request(Order_1); Subscriber_Order : Subscriber_Request := Subscriber_Request(Order_2); VIP_Order : VIP_Request := VIP_Request(Order_3); Last_Minute_Order : Last_Minute_Request := Last_Minute_Request(Order_4); begin -- Perform a field-by-field comparison of all the class-wide -- objects input from the stream with specific type objects -- originally written to the stream. if Ticket_Order.Location /= Box_Office_Request.Location or Ticket_Order.Number_Of_Tickets /= Box_Office_Request.Number_Of_Tickets then Report.Failed ("Ticket_Request object validation failure"); end if; if Subscriber_Order.Location /= Summer_Subscription.Location or Subscriber_Order.Number_Of_Tickets /= Summer_Subscription.Number_Of_Tickets or Subscriber_Order.Subscription_Number /= Summer_Subscription.Subscription_Number then Report.Failed ("Subscriber_Request object validation failure"); end if; if VIP_Order.Location /= Mayoral_Ticket_Request.Location or VIP_Order.Number_Of_Tickets /= Mayoral_Ticket_Request.Number_Of_Tickets or VIP_Order.Rank /= Mayoral_Ticket_Request.Rank then Report.Failed ("VIP_Request object validation failure"); end if; if Last_Minute_Order.Location /= Late_Request.Location or Last_Minute_Order.Number_Of_Tickets /= Late_Request.Number_Of_Tickets or Last_Minute_Order.Rank /= Late_Request.Rank or Last_Minute_Order.Special_Consideration /= Late_Request.Special_Consideration or Last_Minute_Order.Donation /= Late_Request.Donation then Report.Failed ("Last_Minute_Request object validation failure"); end if; -- Verify tag values from before and after processing. -- The 'Tag attribute is used with objects of a class-wide type. if TC_Box_Office_Tag /= Ada.Tags.External_Tag(Order_1'Tag) then Report.Failed("Failed tag comparison - 1"); end if; if TC_Summer_Tag /= Ada.Tags.External_Tag(Order_2'Tag) then Report.Failed("Failed tag comparison - 2"); end if; if TC_Mayoral_Tag /= Ada.Tags.External_Tag(Order_3'Tag) then Report.Failed("Failed tag comparison - 3"); end if; if TC_Late_Tag /= Ada.Tags.External_Tag(Order_4'Tag) then Report.Failed("Failed tag comparison - 4"); end if; end Process_Order_Block; -- After all the data has been correctly extracted, the file -- should be empty. if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then Report.Failed ("Stream file not empty"); end if; exception when Incomplete => raise; when Constraint_Error => Report.Failed ("Constraint_Error raised in Operational Block"); when others => Report.Failed ("Exception raised in Operational Test Block"); end Operational_Test_Block; Deletion: begin if Ada.Streams.Stream_IO.Is_Open (Order_File) then Ada.Streams.Stream_IO.Delete (Order_File); else Ada.Streams.Stream_IO.Open (Order_File, Ada.Streams.Stream_IO.Out_File, Order_Filename); Ada.Streams.Stream_IO.Delete (Order_File); end if; exception when others => Report.Failed ( "Delete not properly implemented for Stream_IO" ); end Deletion; Report.Result; exception when Incomplete => Report.Result; when others => Report.Failed ( "Unexpected exception" ); Report.Result; end CXACC01;