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

* Add UnicodeFromLocaleChars for Delphi compatibility

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-02-20 17:09:35 +01:00
parent 476780df77
commit 31b978f3b7
2 changed files with 72 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
rtl/inc/ustringh.inc
View File

@ -50,6 +50,14 @@ procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : Uni
procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : AnsiString);
procedure UnicodeCharToStrVar(S : PUnicodeChar;out Dest : AnsiString);
function UnicodeFromLocaleChars(CodePage, Flags: Cardinal; LocaleStr: PAnsiChar;
LocaleStrLen: Integer; UnicodeStr: PWideChar; UnicodeStrLen: Integer): Integer; overload;
function UnicodeFromLocaleChars(const LocaleName: AnsiString; Flags: Cardinal;
LocaleStr: PAnsiChar; LocaleStrLen: Integer; UnicodeStr: PWideChar;
UnicodeStrLen: Integer): Integer; overload;
procedure DefaultUnicode2AnsiMove(source:punicodechar;var dest:RawByteString;cp : TSystemCodePage;len:SizeInt);
procedure DefaultAnsi2UnicodeMove(source:pansichar;cp : TSystemCodePage;var dest:unicodestring;len:SizeInt);
@ -177,3 +185,12 @@ function StringCodePage(const S : UnicodeString): TSystemCodePage; overload;
Function ToSingleByteFileSystemEncodedFileName(const Str: UnicodeString): RawByteString;
Function ToSingleByteFileSystemEncodedFileName(const arr: array of widechar): RawByteString;
Function ToSingleByteFileSystemEncodedFileName(const Str: RawByteString): RawByteString;
Type
TLocaleNameToCodePageCallBack = Procedure (const localename : shortstring; out codepage : TSystemCodePage; aHandled : Boolean);
Var
LocaleNameToCodePageCallBack : TLocaleNameToCodePageCallBack;
Function LocaleNameToCodePage(const localename : shortstring; out codepage : TSystemCodePage) : Boolean;

55
rtl/inc/ustrings.inc
View File

@ -1047,6 +1047,40 @@ function StringToWideChar(const Src : RawByteString;Dest : PWideChar;DestSize :
end;
{$endif FPC_HAS_STRING_LEN_TO_WIDECHAR}
function UnicodeFromLocaleChars(CodePage, Flags: Cardinal; LocaleStr: PAnsiChar;
LocaleStrLen: Integer; UnicodeStr: PWideChar; UnicodeStrLen: Integer): Integer; overload;
var
temp: widestring;
Len: SizeInt;
begin
widestringmanager.Ansi2WideMoveProc(LocaleStr,CodePage,temp,LocaleStrLen);
Len:=Length(temp);
// Only move when we have room.
if (UnicodeStrLen>0) then
begin
if UnicodeStrLen<=Len then
Len:=UnicodeStrLen-1;
move(temp[1],UnicodeStr^,Len*SizeOf(WideChar));
UnicodeStr[Len]:=#0;
end;
// Return length
result:=len;
end;
function UnicodeFromLocaleChars(const LocaleName: AnsiString; Flags: Cardinal;
LocaleStr: PAnsiChar; LocaleStrLen: Integer; UnicodeStr: PWideChar;
UnicodeStrLen: Integer): Integer; overload;
var
CP : TSystemCodePage;
begin
if not LocaleNameToCodePage(LocaleName,CP) then
Result:=0
else
Result:=UnicodeFromLocaleChars(CP,Flags,LocaleStr,LocaleStrLen,UnicodeStr,UnicodeStrLen);
end;
{$ifndef FPC_HAS_UNICODECHAR_LEN_TO_STRING}
{$define FPC_HAS_UNICODECHAR_LEN_TO_STRING}
@ -2416,3 +2450,24 @@ begin
Result := UTF8ToString(rs);
end;
{$endif not CPUJVM}
Function LocaleNameToCodePage(const localename : shortstring; out codepage : TSystemCodePage) : Boolean;
begin
Result:=(localename='UTF-8') or (localename='UTF8');
if Result then
CodePage:=CP_UTF8
else
begin
Result:=(localename='UTF-7') or (localename='UTF7');
if Result then
CodePage:=CP_UTF7
else
begin
Result:=Assigned(LocaleNameToCodePageCallBack);
If Result then
LocaleNameToCodePageCallBack(LocaleName,CodePage,Result);
end;
end;
end;