1------------------------------------------------------------------------------ 2-- -- 3-- GNAT2XML COMPONENTS -- 4-- -- 5-- S T R I N G S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2012-2015, AdaCore -- 10-- -- 11-- Gnat2xml is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 2, or (at your option) any later -- 14-- version. Gnat2xml is distributed in the hope that it will be useful, -- 15-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- 16-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with GNAT; see file COPYING. If -- 19-- not, write to the Free Software Foundation, 59 Temple Place Suite 330, -- 20-- Boston, MA 02111-1307, USA. -- 21-- The gnat2xml tool was derived from the Avatox sources. -- 22------------------------------------------------------------------------------ 23 24pragma Ada_2012; 25 26with Ada.Characters.Handling; use Ada.Characters.Handling; 27with Ada.Directories; 28with Ada.Wide_Characters.Handling; use Ada.Wide_Characters.Handling; 29with Ada.Strings.Unbounded; 30with Ada.Strings.Wide_Unbounded; 31with Ada.Text_IO; 32with Ada.Wide_Text_IO; use Ada; 33 34package body ASIS_UL.String_Utilities is 35 36 ------------ 37 -- Append -- 38 ------------ 39 40 procedure Append (X : in out Bounded_Str; C : Character) is 41 begin 42 if X.Length = X.Max_Length then 43 raise Constraint_Error with "Bounded_Str overflow"; 44 end if; 45 X.Length := X.Length + 1; 46 X.Chars (X.Length) := C; 47 end Append; 48 49 procedure Append (X : in out Bounded_Str; S : String) is 50 begin 51 for C of S loop 52 Append (X, C); 53 end loop; 54 end Append; 55 56 procedure Append (X : in out Bounded_W_Str; C : W_Char) is 57 begin 58 if X.Length = X.Max_Length then 59 raise Constraint_Error with "Bounded_W_Str overflow"; 60 end if; 61 X.Length := X.Length + 1; 62 X.Chars (X.Length) := C; 63 end Append; 64 65 procedure Append (X : in out Bounded_W_Str; S : W_Str) is 66 begin 67 for C of S loop 68 Append (X, C); 69 end loop; 70 end Append; 71 72 ------------------- 73 -- Char_To_Digit -- 74 ------------------- 75 76 function Char_To_Digit (C : Character) return Digit is 77 begin 78 return Character'Pos (C) - Character'Pos ('0'); 79 end Char_To_Digit; 80 81 function Char_To_Digit (C : W_Char) return Digit is 82 begin 83 return Char_To_Digit (To_Character (C)); 84 end Char_To_Digit; 85 86 ----------- 87 -- Image -- 88 ----------- 89 90 function Image (X : Integer) return String is 91 Result : constant String := X'Img; 92 93 begin 94 case Result (1) is 95 when ' ' => 96 return Slide (Result (2 .. Result'Last)); 97 98 when '-' => 99 return Result; 100 101 when others => 102 raise Program_Error; 103 end case; 104 end Image; 105 106 function Image (X : Modular) return String is 107 Result : constant String := X'Img; 108 109 begin 110 case Result (1) is 111 when ' ' => 112 return Slide (Result (2 .. Result'Last)); 113 114 when '-' => 115 return Result; 116 117 when others => 118 raise Program_Error; 119 end case; 120 end Image; 121 122 ---------------- 123 -- Capitalize -- 124 ---------------- 125 126 procedure Capitalize (S : in out String) is 127 begin 128 for X in S'Range loop 129 if X = S'First 130 or else not (Is_Letter (S (X - 1)) or else Is_Digit (S (X - 1))) 131 then 132 S (X) := To_Upper (S (X)); 133 134 else 135 S (X) := To_Lower (S (X)); 136 end if; 137 end loop; 138 end Capitalize; 139 140 procedure Capitalize (S : in out W_Str) is 141 begin 142 for X in S'Range loop 143 if X = S'First 144 or else not (Is_Letter (S (X - 1)) or else Is_Digit (S (X - 1))) 145 then 146 S (X) := To_Upper (S (X)); 147 148 else 149 S (X) := To_Lower (S (X)); 150 end if; 151 end loop; 152 end Capitalize; 153 154 function Capitalize (S : String) return String is 155 begin 156 return Result : String (S'Range) do 157 for X in S'Range loop 158 if X = S'First 159 or else not (Is_Letter (S (X - 1)) or else Is_Digit (S (X - 1))) 160 then 161 Result (X) := To_Upper (S (X)); 162 163 else 164 Result (X) := To_Lower (S (X)); 165 end if; 166 end loop; 167 end return; 168 end Capitalize; 169 170 function Capitalize (S : W_Str) return W_Str is 171 begin 172 return Result : W_Str (S'Range) do 173 for X in S'Range loop 174 if X = S'First 175 or else not (Is_Letter (S (X - 1)) or else Is_Digit (S (X - 1))) 176 then 177 Result (X) := To_Upper (S (X)); 178 179 else 180 Result (X) := To_Lower (S (X)); 181 end if; 182 end loop; 183 end return; 184 end Capitalize; 185 186 --------------------------- 187 -- Escape_String_Literal -- 188 --------------------------- 189 190 function Escape_String_Literal (S : String) return String is 191 use Ada.Strings.Unbounded; 192 Result : Unbounded_String; 193 194 begin 195 for C of S loop 196 Append (Result, C); 197 if C = '"' then 198 Append (Result, C); 199 end if; 200 end loop; 201 202 return To_String (Result); 203 end Escape_String_Literal; 204 205 ---------------- 206 -- Has_Prefix -- 207 ---------------- 208 209 function Has_Prefix (X, Prefix : String) return Boolean is 210 begin 211 if X'Length >= Prefix'Length then 212 declare 213 Slice : constant String := 214 To_Lower (X (X'First .. X'First + Prefix'Length - 1)); 215 begin 216 return Slice = To_Lower (Prefix); 217 end; 218 end if; 219 return False; 220 end Has_Prefix; 221 222 function Has_Prefix (X, Prefix : W_Str) return Boolean is 223 begin 224 if X'Length >= Prefix'Length then 225 declare 226 Slice : constant W_Str := 227 To_Lower (X (X'First .. X'First + Prefix'Length - 1)); 228 begin 229 return Slice = To_Lower (Prefix); 230 end; 231 end if; 232 return False; 233 end Has_Prefix; 234 235 ---------------- 236 -- Has_Suffix -- 237 ---------------- 238 239 function Has_Suffix (X, Suffix : String) return Boolean is 240 begin 241 if X'Length >= Suffix'Length then 242 declare 243 Slice : constant String := 244 To_Lower (X (X'Last - Suffix'Length + 1 .. X'Last)); 245 begin 246 return Slice = To_Lower (Suffix); 247 end; 248 end if; 249 return False; 250 end Has_Suffix; 251 252 function Has_Suffix (X, Suffix : W_Str) return Boolean is 253 begin 254 if X'Length >= Suffix'Length then 255 declare 256 Slice : constant W_Str := 257 To_Lower (X (X'Last - Suffix'Length + 1 .. X'Last)); 258 begin 259 return Slice = To_Lower (Suffix); 260 end; 261 end if; 262 return False; 263 end Has_Suffix; 264 265 ------------------ 266 -- Strip_Prefix -- 267 ------------------ 268 269 function Strip_Prefix (X, Prefix : String) return String is 270 begin 271 if Has_Prefix (X, Prefix) then 272 return X (X'First + Prefix'Length .. X'Last); 273 end if; 274 275 return X; 276 end Strip_Prefix; 277 278 function Strip_Prefix (X, Prefix : W_Str) return W_Str is 279 begin 280 if Has_Prefix (X, Prefix) then 281 return X (X'First + Prefix'Length .. X'Last); 282 end if; 283 284 return X; 285 end Strip_Prefix; 286 287 ------------------ 288 -- Strip_Suffix -- 289 ------------------ 290 291 function Strip_Suffix (X, Suffix : String) return String is 292 begin 293 if Has_Suffix (X, Suffix) then 294 return X (X'First .. X'Last - Suffix'Length); 295 end if; 296 297 return X; 298 end Strip_Suffix; 299 300 function Strip_Suffix (X, Suffix : W_Str) return W_Str is 301 begin 302 if Has_Suffix (X, Suffix) then 303 return X (X'First .. X'Last - Suffix'Length); 304 end if; 305 306 return X; 307 end Strip_Suffix; 308 309 ----------- 310 -- Slide -- 311 ----------- 312 313 function Slide (X : String) return String is 314 begin 315 return Result : constant String (1 .. X'Length) := X; 316 end Slide; 317 318 function Slide (X : W_Str) return W_Str is 319 begin 320 return Result : constant W_Str (1 .. X'Length) := X; 321 end Slide; 322 323 ----------------- 324 -- Replace_All -- 325 ----------------- 326 327 function Replace_All (S, From, To : W_Str; 328 Replaced : out Boolean) return W_Str; 329 function Replace_All 330 (S : W_Str_Access; 331 From, To : W_Str; 332 Replaced : out Boolean) 333 return W_Str_Access; 334 335 function Replace_All (S, From, To : W_Str; 336 Replaced : out Boolean) return W_Str is 337 use Ada.Strings.Wide_Unbounded; 338 Result : Unbounded_Wide_String; 339 340 J : Positive := S'First; 341 342 begin 343 Replaced := False; 344 while J <= S'Last loop 345 if J + From'Length - 1 <= S'Last 346 and then S (J .. J + From'Length - 1) = From 347 then 348 Replaced := True; 349 Append (Result, To); 350 J := J + From'Length; 351 352 else 353 Append (Result, S (J)); 354 J := J + 1; 355 end if; 356 end loop; 357 358 return To_Wide_String (Result); 359 end Replace_All; 360 361 function Replace_All 362 (S : W_Str_Access; 363 From, To : W_Str; 364 Replaced : out Boolean) 365 return W_Str_Access 366 is 367 Result : constant W_Str := Replace_All (S.all, From, To, Replaced); 368 Temp : W_Str_Access := S; 369 370 begin 371 if Result'Length = Temp'Length then 372 Temp.all := Result; 373 374 else 375 Free (Temp); 376 Temp := new W_Str'(Result); 377 end if; 378 379 return Temp; 380 end Replace_All; 381 382 function Replace_All (S, From, To : W_Str) return W_Str is 383 Ignore : Boolean; 384 begin 385 return Replace_All (S, From, To, Ignore); 386 end Replace_All; 387 388 function Replace_All 389 (S : W_Str_Access; 390 From, To : W_Str) 391 return W_Str_Access 392 is 393 Ignore : Boolean; 394 begin 395 return Replace_All (S, From, To, Ignore); 396 end Replace_All; 397 398 function Must_Replace (S, From, To : W_Str) return W_Str is 399 Replaced : Boolean; 400 begin 401 return Result : constant W_Str := Replace_All (S, From, To, Replaced) do 402 pragma Assert (Replaced); 403 end return; 404 end Must_Replace; 405 406 function Must_Replace 407 (S : W_Str_Access; 408 From, To : W_Str) 409 return W_Str_Access 410 is 411 Replaced : Boolean; 412 begin 413 return Result : constant W_Str_Access := 414 Replace_All (S, From, To, Replaced) 415 do 416 pragma Assert (Replaced); 417 end return; 418 end Must_Replace; 419 420 -------------------- 421 -- Replace_String -- 422 -------------------- 423 424 function Replace_String (S, From, To : String) return String is 425 use Ada.Strings.Unbounded; 426 Result : Unbounded_String; 427 428 J : Positive := S'First; 429 430 begin 431 while J <= S'Last loop 432 if J + From'Length - 1 <= S'Last 433 and then S (J .. J + From'Length - 1) = From 434 then 435 Append (Result, To); 436 J := J + From'Length; 437 438 else 439 Append (Result, S (J)); 440 J := J + 1; 441 end if; 442 end loop; 443 444 return To_String (Result); 445 end Replace_String; 446 447 ------------------- 448 -- Strip_Article -- 449 ------------------- 450 451 function Strip_Article (S : String) return String is 452 begin 453 return Strip_Prefix (Strip_Prefix (S, Prefix => "A_"), Prefix => "AN_"); 454 end Strip_Article; 455 456 function Strip_Article (S : W_Str) return W_Str is 457 begin 458 return Strip_Prefix (Strip_Prefix (S, Prefix => "A_"), Prefix => "AN_"); 459 end Strip_Article; 460 461 --------------------------- 462 -- Wide_Text_IO_Put_Char -- 463 --------------------------- 464 465 procedure Wide_Text_IO_Put_Char (C : Character) is 466 begin 467 Wide_Text_IO_Put_Char (To_Wide_Character (C)); 468 end Wide_Text_IO_Put_Char; 469 470 procedure Wide_Text_IO_Put_Char (C : W_Char) is 471 begin 472 if C = NL then 473 Wide_Text_IO.New_Line; 474 else 475 Wide_Text_IO.Put (C); 476 end if; 477 end Wide_Text_IO_Put_Char; 478 479 ---------------------- 480 -- Std_Err_Put_Char -- 481 ---------------------- 482 483 procedure Std_Err_Put_Char (C : Character) is 484 begin 485 if C = ASCII.LF then 486 Text_IO.New_Line (Text_IO.Standard_Error); 487 488 else 489 Text_IO.Put (Text_IO.Standard_Error, C); 490 end if; 491 end Std_Err_Put_Char; 492 493 --------------- 494 -- Read_File -- 495 --------------- 496 497 function Read_File (FD : File_Descriptor) return String_Access is 498 Length : constant Natural := Natural (File_Length (FD)); 499 500 This_Read : Integer; 501 Read_Ptr : Natural := 1; 502 503 Buffer : constant String_Access := new String (1 .. Length); 504 begin 505 loop 506 This_Read := 507 Read 508 (FD, 509 A => Buffer.all'Address, 510 N => Length + 1 - Read_Ptr); 511 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); 512 exit when This_Read <= 0 or else Read_Ptr = Length + 1; 513 end loop; 514 515 if Read_Ptr /= Length + 1 then 516 raise Program_Error with "Read_File failed"; 517 end if; 518 519 return Buffer; 520 end Read_File; 521 522 function Read_File (File_Name : String) return String_Access is 523 524 FD : constant File_Descriptor := Open_Read (File_Name, Fmode => Binary); 525 526 begin 527 if FD = Invalid_FD then 528 raise Program_Error with "file not found: " & File_Name; 529 end if; 530 531 return Result : constant String_Access := Read_File (FD) do 532 Close (FD); 533 end return; 534 end Read_File; 535 536 ----------------------- 537 -- Parallel_Make_Dir -- 538 ----------------------- 539 540 procedure Parallel_Make_Dir 541 (New_Directory : String; Give_Message : Boolean := False) 542 is 543 use Ada.Directories; 544 begin 545 if not Exists (New_Directory) then 546 begin 547 Create_Path (New_Directory); 548 if Give_Message then 549 Text_IO.Put_Line ("Created directory " & New_Directory); 550 end if; 551 exception 552 when Use_Error => 553 -- Ignore error; some other process probably created it. Check 554 -- for that below. 555 null; 556 end; 557 end if; 558 if not Exists (New_Directory) 559 or else Kind (New_Directory) /= Directory 560 then 561 raise Use_Error with "cannot create directory " & New_Directory; 562 end if; 563 end Parallel_Make_Dir; 564 565 --------------- 566 -- Move_File -- 567 --------------- 568 569 procedure Move_File (Old_Name : String; New_Name : String) is 570 Success, Delete_Success : Boolean; 571 begin 572 -- There are two reasons for the following shenanigans: 573 -- 574 -- Rename_File is nonportable; on some systems it fails if the New_Name 575 -- already exists, so we need to delete it first. 576 -- 577 -- If the New_Name is a (writable) file in a non-writable directory, 578 -- we need to copy the file; deleting or renaming the file will fail. 579 -- 580 -- So we first try to rename. If that fails, we either delete and retry 581 -- the rename, or else we copy. 582 583 Rename_File (Old_Name, New_Name, Success); 584 if not Success then 585 if Is_Writable_File (Directories.Containing_Directory (New_Name)) then 586 if Is_Regular_File (New_Name) then 587 Delete_File (New_Name, Success); 588 if not Success then 589 raise Program_Error with "unable to overwrite " & New_Name; 590 end if; 591 end if; 592 Rename_File (Old_Name, New_Name, Success); 593 if not Success then 594 raise Program_Error with 595 "unable to move " & Old_Name & " to " & New_Name; 596 end if; 597 else 598 Copy_File (Old_Name, New_Name, Success, Mode => Overwrite); 599 Delete_File (Old_Name, Delete_Success); 600 if not Success then 601 raise Program_Error with 602 "unable to copy " & Old_Name & " to " & New_Name; 603 end if; 604 if not Delete_Success then 605 raise Program_Error with "unable to delete " & Old_Name; 606 end if; 607 end if; 608 end if; 609 end Move_File; 610 611 -------------- 612 -- To_Lower -- 613 -------------- 614 615 procedure To_Lower (S : in out String) is 616 begin 617 for X in S'Range loop 618 S (X) := To_Lower (S (X)); 619 end loop; 620 end To_Lower; 621 622 procedure To_Lower (S : in out W_Str) is 623 begin 624 for X in S'Range loop 625 S (X) := To_Lower (S (X)); 626 end loop; 627 end To_Lower; 628 629 --------------- 630 -- To_String -- 631 --------------- 632 633 function To_String (X : Bounded_Str) return String is 634 begin 635 return X.Chars (1 .. X.Length); 636 end To_String; 637 638 function To_String (X : Bounded_W_Str) return W_Str is 639 begin 640 return X.Chars (1 .. X.Length); 641 end To_String; 642 643end ASIS_UL.String_Utilities; 644