rtl:

  - fix compilation of character.pas by fpc 2.4
  - check TCharacter method arguments and raise appropriate EArgumentException or EArgumentOutOfRangeException exceptions
  - implement to/from UTF32 conversion based on utf16toutf32 and friends

git-svn-id: trunk@19183 -

rtl/objpas/character.pas

@@ -1,6 +1,7 @@
 unit character;
 
 interface
+{$ifndef VER2_4}
 {$mode objfpc}
 {$H+}
 {$PACKENUM 1}
@@ -51,11 +52,10 @@ type
 
   TCharacter = class sealed
   public
-    {class function ConvertFromUtf32(AChar : UCS4Char) : UnicodeString; static;
-    
+    class function ConvertFromUtf32(AChar : UCS4Char) : UnicodeString; static;
     class function ConvertToUtf32(const AString : UnicodeString; AIndex : Integer) : UCS4Char; overload; static;
     class function ConvertToUtf32(const AString : UnicodeString; AIndex : Integer; out ACharLength : Integer) : UCS4Char; overload; static;
-    class function ConvertToUtf32(AHighSurrogate, ALowSurrogate : UnicodeChar; AIndex : Integer) : UCS4Char; overload; static;}
+    class function ConvertToUtf32(const AHighSurrogate, ALowSurrogate : UnicodeChar) : UCS4Char; overload; static;
     
     class function GetNumericValue(AChar : UnicodeChar) : Double; static; overload;
     class function GetNumericValue(const AString : UnicodeString; AIndex : Integer) : Double; overload; static;
@@ -112,9 +112,13 @@ type
     class function ToUpper(const AString : UnicodeString) : UnicodeString; overload; static;
   end;
 
+{$endif VER2_4}
+
 implementation
-uses  
-  SysUtils;
+{$ifndef VER2_4}
+uses
+  SysUtils,
+  RtlConsts;
 
 type  
   PUC_Prop = ^TUC_Prop;
@@ -133,7 +137,11 @@ const
   LOW_SURROGATE_END    = Word($DFFF); 
   
   HIGH_SURROGATE_BEGIN = Word($D800); 
-  HIGH_SURROGATE_END   = Word($DBFF); 
+  HIGH_SURROGATE_END   = Word($DBFF);
+
+  UCS4_HALF_BASE       = LongWord($10000);
+  UCS4_HALF_MASK       = Word($3FF);
+  MAX_LEGAL_UTF32      = $10FFFF;
     
 const
   LETTER_CATEGORIES = [
@@ -163,7 +171,7 @@ const
       TUnicodeCategory.ucModifierSymbol, TUnicodeCategory.ucOtherSymbol
     ];
 
-function GetProps(const ACodePoint : Word) : PUC_Prop; //inline;
+class function GetProps(const ACodePoint : Word) : PUC_Prop; inline;
 begin
   Result:=
     @UC_PROP_ARRAY[
@@ -172,10 +180,67 @@ begin
          WordRec(ACodePoint).Lo
        ]
      ];
-end;                 
+end;
 
 { TCharacter }
 
+class function TCharacter.ConvertFromUtf32(AChar : UCS4Char) : UnicodeString; static;
+begin
+  if AChar < UCS4_HALF_BASE then
+  begin
+    if IsSurrogate(UnicodeChar(AChar)) then
+      raise EArgumentOutOfRangeException.CreateFmt(SInvalidUTF32Char, [AChar]);
+    Result := UnicodeChar(AChar);
+  end
+  else
+  begin
+    if AChar > MAX_LEGAL_UTF32 then
+      raise EArgumentOutOfRangeException.CreateFmt(SInvalidUTF32Char, [AChar]);
+    SetLength(Result, 2);
+    AChar := AChar - UCS4_HALF_BASE;
+    Result[1] := UnicodeChar((AChar shr 10) + HIGH_SURROGATE_BEGIN);
+    Result[2] := UnicodeChar((AChar and UCS4_HALF_MASK) + LOW_SURROGATE_BEGIN);
+  end;
+end;
+
+class function TCharacter.ConvertToUtf32(const AString : UnicodeString; AIndex : Integer) : UCS4Char; overload; static;
+begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := Word(AString[AIndex]);
+  if IsHighSurrogate(UnicodeChar(Result)) then
+  begin
+    if Length(AString) < Succ(AIndex) then
+      raise EArgumentException.CreateFmt(SInvalidHighSurrogate, [AIndex]);
+    Result := ConvertToUtf32(UnicodeChar(Result), AString[Succ(AIndex)]);
+  end;
+end;
+
+class function TCharacter.ConvertToUtf32(const AString : UnicodeString; AIndex : Integer; out ACharLength : Integer) : UCS4Char; overload; static;
+begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := Word(AString[AIndex]);
+  if IsHighSurrogate(UnicodeChar(Result)) then
+  begin
+    if Length(AString) < Succ(AIndex) then
+      raise EArgumentException.CreateFmt(SInvalidHighSurrogate, [AIndex]);
+    Result := ConvertToUtf32(UnicodeChar(Result), AString[Succ(AIndex)]);
+    ACharLength := 2;
+  end
+  else
+    ACharLength := 1;
+end;
+
+class function TCharacter.ConvertToUtf32(const AHighSurrogate, ALowSurrogate : UnicodeChar) : UCS4Char; overload; static;
+begin
+  if not IsHighSurrogate(AHighSurrogate) then
+    raise EArgumentOutOfRangeException.CreateFmt(SHighSurrogateOutOfRange, [Word(AHighSurrogate)]);
+  if not IsLowSurrogate(ALowSurrogate) then
+    raise EArgumentOutOfRangeException.CreateFmt(SLowSurrogateOutOfRange, [Word(AHighSurrogate)]);
+  Result := (UCS4Char(AHighSurrogate) - HIGH_SURROGATE_BEGIN) shl 10 + (UCS4Char(ALowSurrogate) - LOW_SURROGATE_BEGIN) + UCS4_HALF_BASE;
+end;
+
 class function TCharacter.GetNumericValue(AChar : UnicodeChar) : Double; static;
 begin
   Result := GetProps(Word(AChar))^.NumericValue;
@@ -186,6 +251,8 @@ class function TCharacter.GetNumericValue(
         AIndex  : Integer
 ) : Double; static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := GetNumericValue(AString[AIndex]);
 end;  
 
@@ -199,7 +266,9 @@ class function TCharacter.GetUnicodeCategory(
         AIndex  : Integer
 ) : TUnicodeCategory; static;
 begin   
-  Result := GetUnicodeCategory(AString[AIndex]);  
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := GetUnicodeCategory(AString[AIndex]);
 end;
 
 class function TCharacter.IsControl(AChar : UnicodeChar) : Boolean; static;
@@ -212,6 +281,8 @@ class function TCharacter.IsControl(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsControl(AString[AIndex]);
 end;
 
@@ -225,7 +296,9 @@ class function TCharacter.IsDigit(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
-  Result := IsDigit(AString[AIndex]);   
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := IsDigit(AString[AIndex]);
 end;
 
 class function TCharacter.IsSurrogate(AChar : UnicodeChar) : Boolean; static;
@@ -238,7 +311,9 @@ class function TCharacter.IsSurrogate(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
-  Result := IsSurrogate(AString[AIndex]); 
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := IsSurrogate(AString[AIndex]);
 end;
 
 class function TCharacter.IsHighSurrogate(AChar : UnicodeChar) : Boolean; static;
@@ -253,7 +328,9 @@ class function TCharacter.IsHighSurrogate(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
-  Result := IsHighSurrogate(AString[AIndex]); 
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := IsHighSurrogate(AString[AIndex]);
 end;
 
 class function TCharacter.IsLowSurrogate(AChar : UnicodeChar) : Boolean; static;
@@ -268,7 +345,9 @@ class function TCharacter.IsLowSurrogate(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
-  Result := IsLowSurrogate(AString[AIndex]); 
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := IsLowSurrogate(AString[AIndex]);
 end;
 
 class function TCharacter.IsSurrogatePair(
@@ -290,6 +369,8 @@ class function TCharacter.IsSurrogatePair(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsSurrogatePair(AString[AIndex],AString[AIndex+1]);
 end;
 
@@ -303,6 +384,8 @@ class function TCharacter.IsLetter(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsLetter(AString[AIndex]);
 end;
 
@@ -316,7 +399,9 @@ class function TCharacter.IsLetterOrDigit(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
-  Result := IsLetterOrDigit(AString[AIndex]); 
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := IsLetterOrDigit(AString[AIndex]);
 end;
 
 class function TCharacter.IsLower(AChar : UnicodeChar) : Boolean; static;
@@ -329,7 +414,9 @@ class function TCharacter.IsLower(
         AIndex  : Integer
 ) : Boolean; static;
 begin        
-  Result := IsLower(AString[AIndex]); 
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
+  Result := IsLower(AString[AIndex]);
 end;
 
 class function TCharacter.IsNumber(AChar : UnicodeChar) : Boolean; static;
@@ -342,6 +429,8 @@ class function TCharacter.IsNumber(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsNumber(AString[AIndex]);
 end;
 
@@ -355,6 +444,8 @@ class function TCharacter.IsPunctuation(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsPunctuation(AString[AIndex]);
 end;
 
@@ -368,6 +459,8 @@ class function TCharacter.IsSeparator(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsSeparator(AString[AIndex]);
 end;
 
@@ -381,6 +474,8 @@ class function TCharacter.IsSymbol(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsSymbol(AString[AIndex]);
 end;
 
@@ -394,6 +489,8 @@ class function TCharacter.IsUpper(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsUpper(AString[AIndex]);
 end;
 
@@ -407,6 +504,8 @@ class function TCharacter.IsWhiteSpace(
         AIndex  : Integer
 ) : Boolean;static;
 begin
+  if (AIndex < 1) or (AIndex > Length(AString)) then
+    raise EArgumentOutOfRangeException.CreateFmt(SStringIndexOutOfRange, [AIndex, Length(AString)]);
   Result := IsWhiteSpace(AString[AIndex]);
 end;
 
@@ -459,5 +558,5 @@ begin
     end;
   end;
 end;
-
+{$endif VER2_4}
 end.

rtl/objpas/rtlconst.inc

@@ -289,6 +289,11 @@ ResourceString
   sWindowsSocketError           = 'A Windows socket error occurred: %s (%d), on API "%s"';
   SWriteError                   = 'Stream write error';
   SYesButton                    = '&Yes';
+  SStringIndexOutOfRange        = 'String index %d out of range [1 - %d]';
+  SHighSurrogateOutOfRange      = 'High surrogate $%x out of range [$D800 - $DBFF]';
+  SLowSurrogateOutOfRange       = 'Low surrogate $%x out of range [$DC00 - $DFFF]';
+  SInvalidUTF32Char             = 'Invalid UTF32 character $%x. Valid UTF32 character must be in range [$0 - $10FFFF] except surrogate range [$D800-$DFFF]';
+  SInvalidHighSurrogate         = 'Invalid high surrogate at index %d. High surrogate must be followed by a low surrogate pair';
 
 { ---------------------------------------------------------------------
     Keysim Names