1-- 2-- Copyright (c) 2007, 2008 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 Ahven.SList; 18with Ahven.AStrings; 19with Ahven.Long_AStrings; 20 21pragma Elaborate_All (Ahven.SList); 22 23-- Like the name implies, the Results package is used for 24-- storing the test results. 25-- 26-- Result_Info holds one invidual result and 27-- Result_Collection holds multiple Result_Infos. 28-- 29package Ahven.Results is 30 use Ahven.AStrings; 31 32 type Result_Info is private; 33 34 Empty_Result_Info : constant Result_Info; 35 -- Result_Info object which holds no result. It can be used 36 -- to initialize a new Result_Info object. 37 38 procedure Set_Test_Name (Info : in out Result_Info; 39 Name : Bounded_String); 40 -- Set a test name for the result. 41 42 procedure Set_Routine_Name (Info : in out Result_Info; 43 Name : Bounded_String); 44 -- Set a routine name for the result. 45 46 procedure Set_Message (Info : in out Result_Info; 47 Message : Bounded_String); 48 -- Set a message for the result. 49 50 procedure Set_Test_Name (Info : in out Result_Info; Name : String); 51 -- A helper function, which calls Set_Test_Name (.. ; Bounded_String) 52 53 procedure Set_Routine_Name (Info : in out Result_Info; Name : String); 54 -- A helper function, which calls Set_Routine_Name (.. ; Bounded_String) 55 56 procedure Set_Message (Info : in out Result_Info; Message : String); 57 -- A helper function, which calls Set_Message (.. ; Bounded_String) 58 59 procedure Set_Long_Message (Info : in out Result_Info; 60 Message : Bounded_String); 61 -- Set a long message for the result 62 63 procedure Set_Long_Message 64 (Info : in out Result_Info; 65 Message : Long_AStrings.Bounded_String); 66 -- Set a long message for the result 67 68 procedure Set_Long_Message (Info : in out Result_Info; Message : String); 69 -- A helper function, which calls Set_Long_Message (.. ; Bounded_String) 70 71 procedure Set_Execution_Time (Info : in out Result_Info; 72 Elapsed_Time : Duration); 73 -- Set the execution time of the result info (test). 74 75 procedure Set_Output_File (Info : in out Result_Info; 76 Filename : Bounded_String); 77 -- Set the name of the test output file. 78 79 procedure Set_Output_File (Info : in out Result_Info; 80 Filename : String); 81 -- Set the name of the test output file. 82 83 function Get_Test_Name (Info : Result_Info) return String; 84 -- Return the test name of the result info. 85 86 function Get_Routine_Name (Info : Result_Info) return String; 87 -- Return the routine name of the result info. 88 89 function Get_Message (Info : Result_Info) return String; 90 -- Return the message of the result info. 91 92 function Get_Long_Message (Info : Result_Info) return String; 93 -- Return the long message of the result info. 94 95 function Get_Execution_Time (Info : Result_Info) return Duration; 96 -- Return the execution time of the result info. 97 98 function Get_Output_File (Info : Result_Info) return Bounded_String; 99 -- Return the name of the output file. 100 -- Empty string is returned in case there is no output file. 101 102 type Result_Collection is limited private; 103 -- A collection of Result_Info objects. 104 -- Contains also child collections. 105 106 type Result_Collection_Access is access Result_Collection; 107 108 procedure Add_Child (Collection : in out Result_Collection; 109 Child : Result_Collection_Access); 110 -- Add a child collection to the collection. 111 112 procedure Add_Error (Collection : in out Result_Collection; 113 Info : Result_Info); 114 -- Add a test error to the collection. 115 116 procedure Add_Skipped (Collection : in out Result_Collection; 117 Info : Result_Info); 118 -- Add a skipped test to the collection. 119 120 procedure Add_Failure (Collection : in out Result_Collection; 121 Info : Result_Info); 122 -- Add a test failure to the collection. 123 124 procedure Add_Pass (Collection : in out Result_Collection; 125 Info : Result_Info); 126 -- Add a passed test to the collection 127 128 procedure Release (Collection : in out Result_Collection); 129 -- Release resourced held by the collection. 130 -- Frees also all children added via Add_Child. 131 132 procedure Set_Name (Collection : in out Result_Collection; 133 Name : Bounded_String); 134 -- Set a test name for the collection. 135 136 procedure Set_Parent (Collection : in out Result_Collection; 137 Parent : Result_Collection_Access); 138 -- Set a parent collection to the collection. 139 140 function Test_Count (Collection : Result_Collection) return Natural; 141 -- Return the amount of tests in the collection. 142 -- Tests in child collections are included. 143 144 function Direct_Test_Count (Collection : Result_Collection) return Natural; 145 -- Return the amount of tests in the collection. 146 -- The tests in the child collections are NOT included. 147 148 function Pass_Count (Collection : Result_Collection) return Natural; 149 -- Return the amount of passed tests in the collection. 150 -- Tests in child collections are included. 151 152 function Error_Count (Collection : Result_Collection) return Natural; 153 -- Return the amount of test errors in the collection. 154 -- Tests in child collections are included. 155 156 function Failure_Count (Collection : Result_Collection) return Natural; 157 -- Return the amount of test errors in the collection. 158 -- Tests in child collections are included. 159 160 function Skipped_Count (Collection : Result_Collection) return Natural; 161 -- Return the amount of skipped tests in the colleciton. 162 -- Tests in child collections are included. 163 164 function Get_Test_Name (Collection : Result_Collection) 165 return Bounded_String; 166 -- Return the name of the collection's test. 167 168 function Get_Parent (Collection : Result_Collection) 169 return Result_Collection_Access; 170 -- Return the parent of the collection. 171 172 function Get_Execution_Time (Collection : Result_Collection) 173 return Duration; 174 -- Return the execution time of the whole collection. 175 176 type Result_Info_Cursor is private; 177 -- A cursor type for Pass, Failure and Error results. 178 179 function First_Pass (Collection : Result_Collection) 180 return Result_Info_Cursor; 181 -- Get the first pass from the collection. 182 183 function First_Failure (Collection : Result_Collection) 184 return Result_Info_Cursor; 185 -- Get the first failure from the collection. 186 187 function First_Skipped (Collection : Result_Collection) 188 return Result_Info_Cursor; 189 -- Get the first skipped test from the collection. 190 191 function First_Error (Collection : Result_Collection) 192 return Result_Info_Cursor; 193 -- Get the first error from the collection. 194 195 function Next (Position : Result_Info_Cursor) return Result_Info_Cursor; 196 -- Get the next pass/failure/error. 197 198 function Data (Position : Result_Info_Cursor) return Result_Info; 199 -- Get the data behind the cursor. 200 201 function Is_Valid (Position : Result_Info_Cursor) return Boolean; 202 -- Is the cursor still valid? 203 204 type Result_Collection_Cursor is private; 205 -- Cursor for iterating over a set of Result_Collection access objects. 206 207 function First_Child (Collection : in Result_Collection) 208 return Result_Collection_Cursor; 209 -- Get the first child of the collection. 210 211 function Next (Position : Result_Collection_Cursor) 212 return Result_Collection_Cursor; 213 -- Get the next child. 214 215 function Is_Valid (Position : Result_Collection_Cursor) return Boolean; 216 -- Is the cursor still valid? 217 218 function Data (Position : Result_Collection_Cursor) 219 return Result_Collection_Access; 220 -- Get the data (Result_Collection_Access) behind the cursor. 221 222 function Child_Depth (Collection : Result_Collection) return Natural; 223 -- Return the maximum depth of children. (a child of a child, etc.) 224 -- 225 -- Examples: Child_Depth is 0 for a collection without children. 226 -- Collection with a child containing another child has a depth of 2. 227 228private 229 type Result_Info is record 230 Test_Name : Bounded_String := Null_Bounded_String; 231 Output_File : Bounded_String := Null_Bounded_String; 232 Routine_Name : Bounded_String := Null_Bounded_String; 233 Execution_Time : Duration := 0.0; 234 Message : Bounded_String := Null_Bounded_String; 235 Long_Message : Long_AStrings.Bounded_String 236 := Long_AStrings.Null_Bounded_String; 237 end record; 238 239 Empty_Result_Info : constant Result_Info := 240 (Test_Name => Null_Bounded_String, 241 Routine_Name => Null_Bounded_String, 242 Message => Null_Bounded_String, 243 Long_Message => Long_AStrings.Null_Bounded_String, 244 Execution_Time => 0.0, 245 Output_File => Null_Bounded_String); 246 247 package Result_Info_List is 248 new Ahven.SList (Element_Type => Result_Info); 249 250 type Result_Collection_Wrapper is record 251 Ptr : Result_Collection_Access; 252 end record; 253 -- Work around for Janus/Ada 3.1.1d/3.1.2beta generic bug. 254 255 package Result_List is 256 new Ahven.SList (Element_Type => Result_Collection_Wrapper); 257 258 type Result_Info_Cursor is new Result_Info_List.Cursor; 259 260 type Result_Collection_Cursor is new Result_List.Cursor; 261 262 type Result_Collection is limited record 263 Test_Name : Bounded_String := Null_Bounded_String; 264 Passes : Result_Info_List.List; 265 Failures : Result_Info_List.List; 266 Errors : Result_Info_List.List; 267 Skips : Result_Info_List.List; 268 Children : Result_List.List; 269 Parent : Result_Collection_Access := null; 270 end record; 271end Ahven.Results; 272