paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 03:59:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ uppercase/lowercase(unicodestring) (fixes a warning in fina.inc when

Browse Source 
compiled with unicodestring)
  * changed uppercase/lowercase(ansistring) to use the same logic as the
    new unicode versions (unify code for lower/upper, only make result
    unique if necessary)
  + test for all four routines

git-svn-id: branches/cpstrrtl@25006 -
This commit is contained in:
Jonas Maebe 2013-06-28 12:46:25 +00:00
parent bae3c0296e
commit 5ed4e99dc1
6 changed files with 202 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -12105,6 +12105,7 @@ tests/test/units/sysutils/tsscanf.pp svneol=native#text/plain
tests/test/units/sysutils/tstrcmp.pp svneol=native#text/plain
tests/test/units/sysutils/tstrtobool.pp svneol=native#text/plain
tests/test/units/sysutils/tunifile.pp svneol=native#text/plain
tests/test/units/sysutils/tuplow.pp svneol=native#text/plain
tests/test/units/sysutils/twstrcmp.pp svneol=native#text/plain
tests/test/units/ucomplex/tcsqr1.pp svneol=native#text/pascal
tests/test/units/variants/tcustomvariant.pp svneol=native#text/plain

71
rtl/objpas/sysutils/sysstr.inc
View File

@ -76,48 +76,49 @@ begin
Dest := Dest + S;
end ;
Function InternalChangeCase(Const S : AnsiString; const Chars: TSysCharSet; const Adjustment: Longint): AnsiString;
var
i : Integer;
P : PChar;
Unique : Boolean;
begin
Result := S;
if Result='' then
exit;
Unique:=false;
P:=PChar(Result);
for i:=1 to Length(Result) do
begin
if CharInSet(P^,Chars) then
begin
if not Unique then
begin
UniqueString(Result);
p:=@Result[i];
Unique:=true;
end;
P^:=Char(Ord(P^)+Adjustment);
end;
Inc(P);
end;
end;
{ UpperCase returns a copy of S where all lowercase characters ( from a to z )
have been converted to uppercase }
Function UpperCase(Const S : AnsiString) : AnsiString;
begin
Result:=InternalChangeCase(S,['a'..'z'],-32);
end;
Function UpperCase(Const S : String) : String;
Var
i : Integer;
P : PChar;
begin
Result := S;
if not assigned(pointer(result)) then exit;
UniqueString(Result);
P:=Pchar(pointer(Result));
for i := 1 to Length(Result) do
begin
if (P^ in ['a'..'z']) then P^ := char(byte(p^) - 32);
Inc(P);
end;
end;
{ LowerCase returns a copy of S where all uppercase characters ( from A to Z )
have been converted to lowercase }
Function Lowercase(Const S : AnsiString) : AnsiString;
begin
Result:=InternalChangeCase(S,['A'..'Z'],32);
end;
Function Lowercase(Const S : String) : String;
Var
i : Integer;
P : PChar;
begin
Result := S;
if not assigned(pointer(result)) then exit;
UniqueString(Result);
P:=Pchar(pointer(Result));
for i := 1 to Length(Result) do
begin
if (P^ in ['A'..'Z']) then P^ := char(byte(p^) + 32);
Inc(P);
end;
end;
function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif}
begin

2
rtl/objpas/sysutils/sysstrh.inc
View File

@ -68,7 +68,7 @@ procedure DisposeStr(S: PString); overload;
procedure DisposeStr(S: PShortString); overload;
procedure AssignStr(var P: PString; const S: string);
procedure AppendStr(var Dest: String; const S: string);
function UpperCase(const s: string): string;
function UpperCase(const s: string): string; overload;
function LowerCase(const s: string): string; overload;
{ the compiler can't decide else if it should use the char or the ansistring
version for a variant }

44
rtl/objpas/sysutils/sysuni.inc
View File

@ -50,6 +50,50 @@ function TrimRight(const S: unicodestring): unicodestring;
end;
Function InternalChangeCase(Const S : UnicodeString; const Chars: TSysCharSet; const Adjustment: Longint): UnicodeString;
var
i : Integer;
P : PWideChar;
Unique : Boolean;
begin
Result := S;
if Result='' then
exit;
Unique:=false;
P:=PWideChar(Result);
for i:=1 to Length(Result) do
begin
if CharInSet(P^,Chars) then
begin
if not Unique then
begin
UniqueString(Result);
p:=@Result[i];
Unique:=true;
end;
P^:=WideChar(Ord(P^)+Adjustment);
end;
Inc(P);
end;
end;
{ UpperCase returns a copy of S where all lowercase characters ( from a to z )
have been converted to uppercase }
Function UpperCase(Const S : UnicodeString) : UnicodeString;
begin
Result:=InternalChangeCase(S,['a'..'z'],-32);
end;
{ LowerCase returns a copy of S where all uppercase characters ( from A to Z )
have been converted to lowercase }
Function Lowercase(Const S : UnicodeString) : UnicodeString;
begin
Result:=InternalChangeCase(S,['A'..'Z'],32);
end;
function UnicodeUpperCase(const s : UnicodeString) : UnicodeString;{$ifdef SYSUTILSINLINE}inline;{$endif}
begin
result:=widestringmanager.UpperUnicodeStringProc(s);

3
rtl/objpas/sysutils/sysunih.inc
View File

@ -18,6 +18,9 @@ function Trim(const S: unicodestring): unicodestring;
function TrimLeft(const S: unicodestring): unicodestring;
function TrimRight(const S: unicodestring): unicodestring;
function UpperCase(const s: UnicodeString): UnicodeString; overload;
function LowerCase(const s: UnicodeString): UnicodeString; overload;
function UnicodeUpperCase(const s : UnicodeString) : UnicodeString;{$ifdef SYSUTILSINLINE}inline;{$endif}
function UnicodeLowerCase(const s : UnicodeString) : UnicodeString;{$ifdef SYSUTILSINLINE}inline;{$endif}
function UnicodeCompareStr(const s1, s2 : UnicodeString) : PtrInt;{$ifdef SYSUTILSINLINE}inline;{$endif}

117
tests/test/units/sysutils/tuplow.pp Normal file
View File

@ -0,0 +1,117 @@
program tuplow;
{$mode objfpc}
{$h+}
uses
SysUtils;
procedure writestring(const s: ansistring);
var
i: longint;
begin
for i:=1 to length(s) do
if (s[i]<=#32) or (s[i]>=#127) then
write('#',ord(s[i]),' ')
else
write(s[i],' ');
writeln;
end;
procedure writestring(const s: unicodestring);
var
i: longint;
begin
for i:=1 to length(s) do
if (s[i]<=#0032) or (s[i]>=#0127) then
write('#',ord(s[i]),' ')
else
write(s[i],' ');
writeln;
end;
procedure error(const s1,s2: ansistring; nr: longint);
var
i: longint;
begin
writeln('error ',nr);
write(' Got: ');
writestring(s1);
write(' Expected: ');
writestring(s2);
halt(nr);
end;
procedure error(const s1,s2: unicodestring; nr: longint);
var
i: longint;
begin
writeln('error ',nr);
write(' Got: ');
writestring(s1);
write(' Expected: ');
writestring(s2);
halt(nr);
end;
procedure testuplowansi;
const
str = #1#2#0#3#128#129#130#131#132#133#134#135#136#137#138#139'aAbBcCdD'#0'fF';
upperstr = #1#2#0#3#128#129#130#131#132#133#134#135#136#137#138#139'AABBCCDD'#0'FF';
lowerstr = #1#2#0#3#128#129#130#131#132#133#134#135#136#137#138#139'aabbccdd'#0'ff';
var
s1, s2: ansistring;
begin
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=uppercase(s1);
if s1<>upperstr then
error(s1,upperstr,1);
if s2<>str then
error(s2,str,2);
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=lowercase(s1);
if s1<>lowerstr then
error(s1,lowerstr,3);
if s2<>str then
error(s2,str,4);
end;
procedure testuplowwide;
const
str = #$0001#$0002#$0000#$0003#0128#0129#0130#0131#0132#0133#0134#0135#0136#0137#0138#0139'AABBCCDD'#0000'FF';
upperstr = #$0001#$0002#$0000#$0003#0128#0129#0130#0131#0132#0133#0134#0135#0136#0137#0138#0139'AABBCCDD'#0000'FF';
lowerstr = #$0001#$0002#$0000#$0003#0128#0129#0130#0131#0132#0133#0134#0135#0136#0137#0138#0139'aabbccdd'#0000'ff';
var
s1, s2: unicodestring;
begin
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=uppercase(s1);
if s1<>upperstr then
error(s1,upperstr,5);
if s2<>str then
error(s2,str,6);
s1:=str;
uniquestring(s1);
s2:=s1;
s1:=lowercase(s1);
if s1<>lowerstr then
error(s1,lowerstr,7);
if s2<>str then
error(s2,str,8);
end;
begin
testuplowansi;
testuplowwide;
end.