------------------------------------------------------------------------------ -- -- -- GNAT2XML COMPONENTS -- -- -- -- S T R I N G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2012-2017, AdaCore -- -- -- -- Gnat2xml is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. Gnat2xml is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- -- Public License for more details. You should have received a copy of the -- -- GNU General Public License distributed with GNAT; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- The gnat2xml tool was derived from the Avatox sources. -- ------------------------------------------------------------------------------ pragma Ada_2012; with Unchecked_Deallocation; with Ada.Containers.Indefinite_Vectors; with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Strings.Wide_Fixed; with Namet; with GNAT.OS_Lib; use GNAT.OS_Lib; package ASIS_UL.String_Utilities is -- String-related utilities subtype W_Char is Wide_Character; subtype W_Str is Wide_String; type W_Str_Access is access all W_Str; procedure Free is new Unchecked_Deallocation (W_Str, W_Str_Access); W_NUL : constant W_Char := W_Char'Val (Character'Pos (ASCII.NUL)); W_LF : constant W_Char := W_Char'Val (Character'Pos (ASCII.LF)); W_CR : constant W_Char := W_Char'Val (Character'Pos (ASCII.CR)); W_FF : constant W_Char := W_Char'Val (Character'Pos (ASCII.FF)); W_HT : constant W_Char := W_Char'Val (Character'Pos (ASCII.HT)); W_VT : constant W_Char := W_Char'Val (Character'Pos (ASCII.VT)); NL : constant W_Char := W_LF; -- Character used to represent new-line in output. function Image (X : Integer) return String; -- Return X'Img without the annoying blank. type Modular is mod 2**32; function Image (X : Modular) return String; function Capitalize (S : String) return String; function Capitalize (S : W_Str) return W_Str; procedure Capitalize (S : in out String); procedure Capitalize (S : in out W_Str); -- Capitalizes the first letter, and all letters following a -- non-letter-or-digit. Converts all others to lower case. procedure To_Lower (S : in out String); procedure To_Lower (S : in out W_Str); -- Same as the ones in Ada.[Wide_]Characters.Handling, except we use a -- procedure to avoid inefficient secondary stack usage. function Escape_String_Literal (S : String) return String; -- Double all the double quotes function Slide (X : String) return String; function Slide (X : W_Str) return W_Str; -- Return X with X'First = 1 function Find (Source : Wide_String; Pattern : Wide_String) return Natural is (Ada.Strings.Wide_Fixed.Index (Source, Pattern)); function Has_Prefix (X, Prefix : String) return Boolean; function Has_Prefix (X, Prefix : W_Str) return Boolean; -- True if Prefix is at the beginning of X, case insensitive. For example, -- Has_Prefix("An_Identifier", Prefix => "an_") is True. function Has_Suffix (X, Suffix : String) return Boolean; function Has_Suffix (X, Suffix : W_Str) return Boolean; -- True if Suffix is at the end of X, case insensitive function Strip_Prefix (X, Prefix : String) return String; function Strip_Prefix (X, Prefix : W_Str) return W_Str; -- If Prefix is at the beginning of X (case insensitive), strip it off function Strip_Suffix (X, Suffix : String) return String; function Strip_Suffix (X, Suffix : W_Str) return W_Str; -- If Suffix is at the end of X (case insensitive), strip it off function Strip_Article (S : String) return String; function Strip_Article (S : W_Str) return W_Str; -- Removes a leading "A_" or "An_" from the string. Case insensitive. function Replace_All (S, From, To : W_Str) return W_Str; function Replace_All (S : W_Str_Access; From, To : W_Str) return W_Str_Access; -- Replaces all occurrences of From in S with To. In the second form, S is -- freed. function Must_Replace (S, From, To : W_Str) return W_Str; function Must_Replace (S : W_Str_Access; From, To : W_Str) return W_Str_Access; -- Same as Replace_All, except these require that at least one substring be -- replaced. function Replace_String (S, From, To : String) return String; -- Same as Replace_All, but for String subtype Digit is Integer range 0 .. 9; function Char_To_Digit (C : Character) return Digit; function Char_To_Digit (C : W_Char) return Digit; -- Converts '0' ==> 0, etc BOM_8 : constant Ada.Strings.UTF_Encoding.UTF_8_String := Ada.Strings.UTF_Encoding.BOM_8; function To_UTF8 (Item : W_Str; Output_BOM : Boolean := False) return Ada.Strings.UTF_Encoding.UTF_8_String renames Ada.Strings.UTF_Encoding.Wide_Strings.Encode; function From_UTF8 (Item : Ada.Strings.UTF_Encoding.UTF_8_String) return W_Str renames Ada.Strings.UTF_Encoding.Wide_Strings.Decode; function W_Name_Find (S : W_Str) return Namet.Name_Id is (Namet.Name_Find (To_UTF8 (S))); -- Wrapper for Namet.Name_Find function Get_Name_String (Id : Namet.Name_Id) return W_Str is (From_UTF8 (Namet.Get_Name_String (Id))); procedure Wide_Text_IO_Put_Char (C : Character); procedure Wide_Text_IO_Put_Char (C : W_Char); -- Put C to Current_Output. Used to instantiate Formatted_Output. procedure Std_Err_Put_Char (C : Character); -- Put C to Standard_Error. Used to instantiate Dbg_Out. function Read_File (FD : File_Descriptor) return String_Access; function Read_File (File_Name : String) return String_Access; -- Reads the entire contents of the file procedure Parallel_Make_Dir (New_Directory : String; Give_Message : Boolean := False); -- Creates a new directory with the given name if it does not already -- exist, creating parent directories as necessary. This is safe for -- parallel processing in the following sense: if two or more processes try -- to create the same directory name at the same time, the directory will -- be created (once), and no exception will be raised. We use this in case -- an ASIS tool is called from gprbuild in parallel using the -j switch. -- If Give_Message is True and the directory is successfully created, a -- message saying so is printed. procedure Move_File (Old_Name : String; New_Name : String); -- Same as GNAT.OS_Lib.Rename_File, but overwrites New_Name if it already -- exists. package String_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, String); subtype String_Vector is String_Vectors.Vector; --------------------- -- Bounded Strings -- --------------------- -- Ada.Strings.Bounded_Strings is too much hassle; we use a simple -- bounded string type here. type Bounded_Str (Max_Length : Natural) is limited record Length : Natural := 0; Chars : String (1 .. Max_Length); end record; procedure Append (X : in out Bounded_Str; C : Character); procedure Append (X : in out Bounded_Str; S : String); function To_String (X : Bounded_Str) return String; function "+" (X : Bounded_Str) return String renames To_String; type Bounded_W_Str (Max_Length : Natural) is limited record Length : Natural := 0; Chars : W_Str (1 .. Max_Length); end record; procedure Append (X : in out Bounded_W_Str; C : W_Char); procedure Append (X : in out Bounded_W_Str; S : W_Str); function To_String (X : Bounded_W_Str) return W_Str; function "+" (X : Bounded_W_Str) return W_Str renames To_String; end ASIS_UL.String_Utilities;