1-- Created On : Fri Apr 26 08:13:44 1996 2 3with Ada.Text_IO; 4with Ada.Strings.Fixed; 5with Ada.Strings.Maps; 6with Ada.Characters.Handling; 7with Ada.Unchecked_Deallocation; 8 9package body Config is 10 11 procedure Free is new Ada.Unchecked_Deallocation(String, Str_Ptr); 12 13 procedure Init(Cfg : out Configuration; 14 File_Name : in String; 15 Case_Sensitive : in Boolean := True; 16 On_Type_Mismatch : in Type_Mismatch_Action := Raise_Data_Error 17 ) 18 is 19 begin 20 Free(Cfg.Config_File); 21 Cfg.Config_File := new String'(File_Name); 22 Cfg.Case_Sensitive:= Case_Sensitive; 23 Cfg.On_Type_Mismatch:= On_Type_Mismatch; 24 end Init; 25 26 function Is_number_start(c: Character) return Boolean is 27 begin 28 case c is 29 when '0'..'9' | '+' | '-' => 30 return True; 31 when others => 32 return False; 33 end case; 34 end Is_number_start; 35 36 -- Internal 37 -- 38 procedure Get_Value(Cfg : in Configuration; 39 Section : in String; 40 Mark : in String; 41 Line : out String; 42 Value_Start : out Natural; 43 Value_End : out Natural; 44 Found_Line : out Natural 45 ) 46 is 47 use Ada.Text_IO; 48 use Ada.Strings.Fixed; 49 use Ada.Strings.Maps; 50 use Ada.Strings; 51 use Ada.Characters.Handling; 52 53 File : File_Type; 54 55 Line_End : Natural := 0; 56 Line_Count : Natural := 0; 57 58 Sect_End : Natural; 59 Comment_Ind : Natural; 60 Equal_Ind : Natural; 61 62 Found_Section_End : Natural; 63 Found_Mark_Start : Natural; 64 Found_Mark_End : Natural := 0; 65 In_Found_Section : Boolean := False; 66 67 Value_Start_Try : Natural; 68 69 begin -- Get_Value 70 Value_Start := Line'First; 71 Value_End := Line'First - 1; 72 Found_Line := 0; 73 Open(File, In_File, Cfg.Config_File.all); 74 Read_File: 75 while not End_Of_File(File) loop 76 Get_Line(File, Line, Line_End); -- error if line end > line'Last 77 Line_Count:= Line_Count + 1; 78 if Line_End > 1 then 79 case Line(Line'First) is 80 when '[' => 81 Sect_End := Index(Source => Line(Line'First .. Line_End), 82 Pattern => "]"); 83 -- error if ext_end = 0 84 Found_Section_End := Sect_End - 1; 85 -- pragma Debug(Put_Line("Config: found_section => " & 86 -- Line(2..Found_Section_End))); 87 if Cfg.Case_Sensitive then 88 In_Found_Section := Section = Line(Line'First+1..Found_Section_End); 89 else 90 In_Found_Section := 91 To_Lower(Section) = To_Lower(Line(Line'First+1..Found_Section_End)); 92 end if; 93 when ';' | '#' => 94 null; -- This is a full-line comment 95 when others => 96 if Section = "*" then 97 In_Found_Section := True; 98 end if; 99 if In_Found_Section then 100 Comment_Ind := Index(Source => Line(Line'First .. Line_End), 101 Set => To_Set("#;")); 102 if Comment_Ind >= Line'First then 103 Line_End := Comment_Ind - 1; 104 end if; 105 Equal_Ind := Index(Source => Line(Line'First .. Line_End), 106 Pattern => "="); 107 if Equal_Ind >= Line'First then 108 Found_Mark_Start := 109 Index_Non_Blank(Line(Line'First .. Equal_Ind-1), Forward); 110 Found_Mark_End := 111 Index_Non_Blank(Line(Line'First .. Equal_Ind-1), Backward); 112 else 113 Found_Mark_Start := 114 Index_Non_Blank(Line(Line'First .. Line_End), Forward); 115 Found_Mark_End := 116 Index_Non_Blank(Line(Line'First .. Line_End), Backward); 117 end if; 118 -- pragma Debug(Put_Line("Config: found_mark => " & 119 -- Line(Found_Mark_start..Found_Mark_End))); 120 if Found_Mark_Start > 0 and then 121 Found_Mark_End > 0 122 then 123 if (Cfg.Case_Sensitive and then 124 (Line(Found_Mark_Start..Found_Mark_End) = Mark)) 125 or else (not Cfg.Case_Sensitive and then 126 (To_Lower(Line(Found_Mark_Start.. 127 Found_Mark_End)) 128 = To_Lower(Mark))) 129 then 130 Found_Line := Line_Count; 131 if Equal_Ind >= Line'First then 132 Value_Start_Try := 133 Index_Non_Blank(Line(Equal_Ind+1..Line_End), 134 Forward); 135 if Value_Start_Try >= Line'First then 136 Value_End := 137 Index_Non_Blank(Line(Value_Start_Try..Line_End), 138 Backward); 139 Value_Start := Value_Start_Try; 140 end if; 141 end if; 142 exit Read_File; 143 end if; 144 end if; 145 end if; 146 end case; 147 end if; 148 end loop Read_File; 149 Close(File); 150 end Get_Value; 151 152 Max_Line_Length: constant:= 1000; 153 154 function Value_Of(Cfg : in Configuration; 155 Section : in String; 156 Mark : in String; 157 Default : in String := "") 158 return String 159 is 160 Line : String(1 .. Max_Line_Length); 161 Value_Start : Natural; 162 Value_End : Natural; 163 Found_Line : Natural; 164 begin 165 Get_Value(Cfg, Section, Mark, Line, Value_Start, Value_End, Found_Line); 166 if Line(Value_Start .. Value_End) = "" then 167 return Default; 168 else 169 return Line(Value_Start .. Value_End); 170 end if; 171 end Value_Of; 172 173 procedure Type_Error(Cfg: in Configuration; Val, Desc: String) is 174 use Ada.Text_IO; 175 begin 176 case Cfg.On_Type_Mismatch is 177 when Raise_Data_Error => 178 raise Ada.Text_IO.Data_Error; 179 180 when Print_Warning => 181 Put_Line( 182 Standard_Error, 183 "Config: warning: `" & val & "' is not " & desc 184 ); 185 186 when Be_Quiet => 187 null; 188 end case; 189 end Type_Error; 190 191 function Value_Of(Cfg : in Configuration; 192 Section : in String; 193 Mark : in String; 194 Default : in Integer := 0) 195 return Integer 196 is 197 Value_As_String : constant String := Value_Of(Cfg, Section, Mark); 198 begin 199 if Value_As_String'Length > 2 and then 200 Value_As_String(Value_As_String'First..Value_As_String'First+1) = "0x" 201 then 202 return Integer'Value("16#" & 203 Value_As_String(Value_As_String'First+2 .. 204 Value_As_String'Last) & 205 "#"); 206 elsif Value_As_String'Length > 0 and then 207 Is_number_start(Value_As_String(Value_As_String'First)) 208 then 209 return Integer'Value(Value_As_String); 210 else 211 Type_Error(Cfg, Value_As_String, "an integer number"); 212 return Default; 213 end if; 214 215 exception 216 when others => 217 Type_Error(Cfg, Value_As_String, "an integer number"); 218 return Default; 219 end Value_Of; 220 221 222 function Value_Of(Cfg : in Configuration; 223 Section : in String; 224 Mark : in String; 225 Default : in Long_Float := 0.0) 226 return Long_Float 227 is 228 Value_As_String : constant String := Value_Of(Cfg, Section, Mark); 229 Val : Long_Float; 230 Last : Positive; 231 package LFIO is new Ada.Text_IO.Float_IO(Long_FLoat); 232 begin 233 if Value_As_String'Length > 0 and then 234 Is_number_start(Value_As_String(Value_As_String'First)) 235 then 236 -- Val := Float'Value(Value_As_String); 237 -- ^ an old compiler doesn't like some floats repr. through 'Value 238 LFIO.Get(Value_As_String, Val, Last); 239 return Val; 240 else 241 Type_Error(Cfg, Value_As_String, "a floating-point number"); 242 return Default; 243 end if; 244 exception 245 when others => 246 Type_Error(Cfg, Value_As_String, "a floating-point number"); 247 return Default; 248 end Value_Of; 249 250 function Value_Of(Cfg : in Configuration; 251 Section : in String; 252 Mark : in String; 253 Default : in Boolean := False) return Boolean 254 is 255 begin 256 return Boolean'Value(Value_Of(Cfg, Section, Mark, Boolean'Image(Default))); 257 end Value_Of; 258 259 -- Return True if one of the following conditions is met: 260 -- o the Mark is within the Section, but no equal sign is in that line, 261 -- o the Mark is set to either 1, True or Yes. 262 -- All other cases return False. 263 function Is_Set(Cfg : in Configuration; 264 Section : in String; 265 Mark : in String) 266 return Boolean is 267 use Ada.Characters.Handling; 268 Line : String(1 .. Max_Line_Length); 269 Value_Start : Natural; 270 Value_End : Natural; 271 Found_Line : Natural; 272 begin 273 Get_Value(Cfg, Section, Mark, Line, Value_Start, Value_End, Found_Line); 274 declare 275 Value : constant String := To_Lower(Line(Value_Start .. Value_End)); 276 begin 277 return Found_Line > 0 and then 278 (Value = "" or else Value = "1" or else 279 Value = "true" or else Value = "yes"); 280 end; 281 end Is_Set; 282 283 function File_Name(Cfg: Configuration) return String is 284 begin 285 return Cfg.Config_File.all; 286 end File_Name; 287 288 -- List of strings, for memorizing a config file. 289 290 type Ini_Line; 291 type Ini_Line_Ptr is access Ini_Line; 292 type Ini_Line is record 293 next: Ini_Line_Ptr:= null; 294 line: Str_Ptr; 295 end record; 296 procedure Free is new Ada.Unchecked_Deallocation(Ini_Line, Ini_Line_Ptr); 297 298 299 procedure Write_and_Free(Cfg : in Configuration; 300 new_contents: in out Ini_Line_Ptr) 301 is 302 curr, to_free: Ini_Line_Ptr:= null; 303 use Ada.Text_IO; 304 File : File_Type; 305 begin 306 Create(File, Out_File, Cfg.Config_File.all); 307 curr:= new_contents; 308 while curr /= null loop 309 Put_Line(File, curr.line.all); 310 to_free:= curr; 311 curr:= curr.next; 312 Free(to_free.line); 313 Free(to_free); 314 end loop; 315 Close(File); 316 new_contents:= null; 317 end Write_and_Free; 318 319 procedure Replace_Value(Cfg : in Configuration; 320 Section : in String; 321 Mark : in String; 322 New_Value: in String) 323 is 324 Line : String(1 .. Max_Line_Length); 325 Value_Start : Natural; 326 Value_End : Natural; 327 Found_Line : Natural; 328 Equal_Ind : Natural; 329 Line_End : Natural := 0; 330 Line_Count : Natural := 0; 331 use Ada.Text_IO; 332 File : File_Type; 333 use Ada.Strings.Fixed; 334 -- 335 root, curr, new_ini_line: Ini_Line_Ptr:= null; 336 begin 337 Get_Value(Cfg, Section, Mark, Line, Value_Start, Value_End, Found_Line); 338 if Found_Line = 0 then 339 raise Location_Not_found; 340 end if; 341 Open(File, In_File, Cfg.Config_File.all); 342 Read_File: 343 while not End_Of_File(File) loop 344 Get_Line(File, Line, Line_End); 345 Line_Count:= Line_Count + 1; 346 -- 347 new_ini_line:= new Ini_Line; 348 if root = null then 349 root:= new_ini_line; 350 else 351 curr.next:= new_ini_line; 352 end if; 353 curr:= new_ini_line; 354 -- 355 if Line_Count = Found_Line then -- Change this line 356 Equal_Ind := Index(Source => Line(1 .. Line_End), 357 Pattern => "="); 358 if Equal_Ind < 1 then -- No '=' yet, will change... 359 curr.line:= new String'(Line(1 .. Line_End) & '=' & New_Value); 360 else 361 curr.line:= new String'(Line(1 .. Equal_Ind) & New_Value); 362 end if; 363 else -- any other line: just copy 364 curr.line:= new String'(Line(1 .. Line_End)); 365 end if; 366 end loop Read_File; 367 Close(File); 368 -- Now, write the new file 369 Write_and_Free(Cfg, root); 370 end Replace_Value; 371 372 procedure Replace_Section(Cfg : in Configuration; 373 Section : in String; 374 New_Contents: in String) 375 is 376 Line : String(1 .. Max_Line_Length); 377 Line_End : Natural := 0; 378 Line_Count : Natural := 0; 379 use Ada.Text_IO; 380 File : File_Type; 381 use Ada.Strings.Fixed; 382 -- 383 root, curr, new_ini_line: Ini_Line_Ptr:= null; 384 -- 385 procedure List_progress is 386 begin 387 new_ini_line:= new Ini_Line; 388 if root = null then 389 root:= new_ini_line; 390 else 391 curr.next:= new_ini_line; 392 end if; 393 curr:= new_ini_line; 394 end; 395 -- 396 Matched_section, Found_section: Boolean:= False; 397 I: Natural:= New_Contents'First; 398 use Ada.Characters.Handling; 399 begin 400 Open(File, In_File, Cfg.Config_File.all); 401 Read_File: 402 while not End_Of_File(File) loop 403 Get_Line(File, Line, Line_End); 404 Line_Count:= Line_Count + 1; 405 if Line_End > 0 and then 406 Line(1)= '[' 407 then -- It is a section header. 408 Matched_section:= 409 Line_End >= 2 + Section'Length and then 410 ( 411 (Cfg.Case_Sensitive and then 412 Line(2..2 + Section'Length) = Section & ']' 413 ) 414 or else 415 ((not Cfg.Case_Sensitive) and then 416 To_Lower(Line(2..2 + Section'Length)) = To_Lower(Section) & ']' 417 ) 418 ); 419 List_progress; 420 curr.line:= new String'(Line(1 .. Line_End)); 421 if Matched_section then 422 Found_section:= True; 423 for J in New_Contents'Range loop -- copy new contents 424 if New_contents(J)= LF then 425 List_progress; 426 curr.line:= new String'(New_contents(I .. J-1)); 427 I:= J+1; 428 end if; 429 if J = New_contents'Last then 430 List_progress; 431 curr.line:= new String'(New_contents(I .. J)); 432 end if; 433 -- NB: we can have have a LF at the end, hence both "if"-s 434 end loop; 435 end if; 436 elsif Matched_section then 437 null; -- don't copy old contents 438 else 439 List_progress; 440 curr.line:= new String'(Line(1 .. Line_End)); 441 end if; 442 end loop Read_File; 443 Close(File); 444 -- Now, write the new file 445 Write_and_Free(Cfg, root); 446 if not Found_Section then 447 raise Section_Not_found; 448 end if; 449 end Replace_Section; 450 451end Config; 452