paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 13:39:39 +01:00
Code Issues Packages Projects Releases Wiki Activity
e949276d9d
fpc/rtl/os2/sysucode.inc
Tomas Hajny 2c566ffcb9 * fix compilation failure after r32262 
git-svn-id: trunk@32270 -
2015-11-08 00:41:00 +00:00

1740 lines
52 KiB
PHP
Raw Blame History

{
This file is part of the Free Pascal run time library.
Copyright (c) 2014-2015 by Tomas Hajny and other members
of the Free Pascal development team.
OS/2 UnicodeStrings support
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
(* The implementation is based on native Unicode support available under
OS/2 Warp 4 and above; if running under OS/2 Warp 3 and UCONV.DLL
library is not available, this implementation will resort to dummy
routines. This still allows providing 3rd party implementation based
e.g. on the ICONV library as an external unit.
*)
const
MaxSpecialCPTranslation = 2;
MaxNonEqualCPMapping = 35;
MaxCPMapping = 76;
CpxAll = 0;
CpxSpecial = 1;
CpxMappingOnly = 2;
Uls_Success = 0;
Uls_API_Error_Base = $20400;
Uls_Other = $20401;
Uls_IllegalSequence = $20402;
Uls_MaxFilesPerProc = $20403;
Uls_MaxFiles = $20404;
Uls_NoOp = $20405;
Uls_TooManyKbd = $20406;
Uls_KbdNotFound = $20407;
Uls_BadHandle = $204008;
Uls_NoDead = $20409;
Uls_NoScan = $2040A;
Uls_InvalidScan = $2040B;
Uls_NotImplemented = $2040C;
Uls_NoMemory = $2040D;
Uls_Invalid = $2040E;
Uls_BadObject = $2040F;
Uls_NoToken = $20410;
Uls_NoMatch = $20411;
Uls_BufferFull = $20412;
Uls_Range = $20413;
Uls_Unsupported = $20414;
Uls_BadAttr = $20415;
Uls_Version = $20416;
UConvName: array [0..5] of char = 'UCONV'#0;
OrdUniCreateUconvObject = 1;
OrdUniUconvToUcs = 2;
OrdUniUconvFromUcs = 3;
OrdUniFreeUconvObject = 4;
OrdUniQueryUconvObject = 7;
OrdUniSetUconvObject = 8;
OrdUniQueryUconvCp = 9;
OrdUniMapCpToUcsCp = 10;
OrdUniStrFromUcs = 11;
OrdUniStrToUcs = 12;
Ord_UniMalloc = 13;
Ord_UniFree = 14;
LibUniName: array [0..6] of char = 'LIBUNI'#0;
OrdUniQueryXdigit = 1;
OrdUniQuerySpace = 2;
OrdUniQueryPrint = 3;
OrdUniQueryGraph = 4;
OrdUniQueryCntrl = 5;
OrdUniQueryAlpha = 6;
OrdUniFreeAttrObject = 7;
OrdUniQueryCharAttr = 8;
OrdUniQueryUpper = 9;
OrdUniQueryPunct = 10;
OrdUniQueryLower = 11;
OrdUniQueryDigit = 12;
OrdUniQueryBlank = 13;
OrdUniQueryAlnum = 14;
OrdUniScanForAttr = 15;
OrdUniCreateAttrObject = 16;
OrdUniCreateTransformObject = 17;
OrdUniFreeTransformObject = 18;
OrdUniQueryLocaleObject = 19;
OrdUniCreateLocaleObject = 20;
OrdUniFreeLocaleObject = 21;
OrdUniFreeMem = 22;
OrdUniFreeLocaleInfo = 28;
OrdUniQueryLocaleInfo = 29;
OrdUniQueryLocaleItem = 30;
OrdUniStrcat = 31;
OrdUniStrchr = 32;
OrdUniStrcmp = 33;
OrdUniStrcmpi = 34;
OrdUniStrColl = 35;
OrdUniStrcpy = 36;
OrdUniStrcspn = 37;
OrdUniStrfmon = 38;
OrdUniStrftime = 39;
OrdUniStrlen = 40;
OrdUniStrncat = 41;
OrdUniStrncmp = 42;
OrdUniStrncmpi = 43;
OrdUniStrncpy = 44;
OrdUniStrpbrk = 45;
OrdUniStrptime = 46;
OrdUniStrrchr = 47;
OrdUniStrspn = 48;
OrdUniStrstr = 49;
OrdUniStrtod = 50;
OrdUniStrtol = 51;
OrdUniStrtoul = 52;
OrdUniStrxfrm = 53;
OrdUniLocaleStrToToken = 54;
OrdUniLocaleTokenToStr = 55;
OrdUniTransformStr = 56;
OrdUniTransLower = 57;
OrdUniTransUpper = 58;
OrdUniTolower = 59;
OrdUniToupper = 60;
OrdUniStrupr = 61;
OrdUniStrlwr = 62;
OrdUniStrtok = 63;
OrdUniMapCtryToLocale = 67;
OrdUniMakeKey = 70;
OrdUniQueryChar = 71;
OrdUniGetOverride = 72;
OrdUniGetColval = 73;
OrdUniQueryAttr = 74;
OrdUniQueryStringType = 75;
OrdUniQueryCharType = 76;
OrdUniQueryNumericValue = 77;
OrdUniQueryCharTypeTable = 78;
OrdUniProcessUconv = 80;
OrdLocale = 151;
OrdUniMakeUserLocale = 152;
OrdUniSetUserLocaleItem = 153;
OrdUniDeleteUserLocale = 154;
OrdUniCompleteUserLocale = 155;
OrdUniQueryLocaleValue = 156;
OrdUniQueryLocaleList = 157;
OrdUniQueryLanguageName = 158;
OrdUniQueryCountryName = 159;
Uni_Token_Pointer = 1;
Uni_MBS_String_Pointer = 2;
Uni_UCS_String_Pointer = 3;
Uni_System_Locales = 1;
Uni_User_Locales = 2;
WNull: WideChar = #0;
WUniv: array [0..4] of WideChar = 'UNIV'#0;
type
(* CP_UTF16 should be in exceptions too, because OS/2 supports only UCS2 *)
(* rather than UTF-16 - ignored at least for now. *)
(* ExceptionWinCodepages = (CP_UTF16BE, CP_UTF7, 12000 {UTF32}, 12001 {UTF32BE});
SpecialWinCodepages = (CP_UTF8, CP_ASCII);*)
TCpRec = record
WinCP: TSystemCodepage;
OS2CP: word;
UConvObj: TUConvObject;
end;
TCpXList = array [1..MaxCPMapping] of TCpRec;
TDummyUConvObject = record
CP: cardinal;
CPNameLen: byte;
CPName: record end;
end;
PDummyUConvObject = ^TDummyUConvObject;
var
DBCSLeadRanges: array [0..11] of char;
CollationSequence: array [char] of char;
const
DefCpRec: TCpRec = (WinCP: 0; OS2CP: 0; UConvObj: nil);
InInitDefaultCP: int64 = -1; (* Range is bigger than TThreadID to avoid conflict *)
DefLocObj: TLocaleObject = nil;
IBMPrefix: packed array [1..4] of WideChar = 'IBM-';
CachedDefFSCodepage: TSystemCodepage = 0;
EmptyCC: TCountryCode = (Country: 0; Codepage: 0); (* Empty = current *)
(* 819 = IBM codepage number for ISO 8859-1 used in FPC default *)
(* dummy translation between UnicodeString and AnsiString. *)
IsoCC: TCountryCode = (Country: 1; Codepage: 819); (* US with ISO 8859-1 *)
(* The following two arrays are initialized on startup in case that *)
(* Dummy* routines must be used. First for current codepage... *)
DBCSLeadRangesEnd: byte = 0;
LowerChars: array [char] of char =
(#0, #1, #2, #3, #4, #5, #6, #7, #8, #9, #10, #11, #12, #13, #14, #15, #16,
#17, #18, #19, #20, #21, #22, #23, #24, #25, #26, #27, #28, #29, #30, #31,
#32, #33, #34, #35, #36, #37, #38, #39, #40, #41, #42, #43, #44, #45, #46,
#47, #48, #49, #50, #51, #52, #53, #54, #55, #56, #57, #58, #59, #60, #61,
#62, #63, #64, #65, #66, #67, #68, #69, #70, #71, #72, #73, #74, #75, #76,
#77, #78, #79, #80, #81, #82, #83, #84, #85, #86, #87, #88, #89, #90, #91,
#92, #93, #94, #95, #96, #97, #98, #99, #100, #101, #102, #103, #104, #105,
#106, #107, #108, #109, #110, #111, #112, #113, #114, #115, #116, #117,
#118, #119, #120, #121, #122, #123, #124, #125, #126, #127, #128, #129,
#130, #131, #132, #133, #134, #135, #136, #137, #138, #139, #140, #141,
#142, #143, #144, #145, #146, #147, #148, #149, #150, #151, #152, #153,
#154, #155, #156, #157, #158, #159, #160, #161, #162, #163, #164, #165,
#166, #167, #168, #169, #170, #171, #172, #173, #174, #175, #176, #177,
#178, #179, #180, #181, #182, #183, #184, #185, #186, #187, #188, #189,
#190, #191, #192, #193, #194, #195, #196, #197, #198, #199, #200, #201,
#202, #203, #204, #205, #206, #207, #208, #209, #210, #211, #212, #213,
#214, #215, #216, #217, #218, #219, #220, #221, #222, #223, #224, #225,
#226, #227, #228, #229, #230, #231, #232, #233, #234, #235, #236, #237,
#238, #239, #240, #241, #242, #243, #244, #245, #246, #247, #248, #249,
#250, #251, #252, #253, #254, #255);
(* ...and now for ISO 8859-1 aka IBM codepage 819 *)
LowerCharsISO88591: array [char] of char =
(#0, #1, #2, #3, #4, #5, #6, #7, #8, #9, #10, #11, #12, #13, #14, #15, #16,
#17, #18, #19, #20, #21, #22, #23, #24, #25, #26, #27, #28, #29, #30, #31,
#32, #33, #34, #35, #36, #37, #38, #39, #40, #41, #42, #43, #44, #45, #46,
#47, #48, #49, #50, #51, #52, #53, #54, #55, #56, #57, #58, #59, #60, #61,
#62, #63, #64, #65, #66, #67, #68, #69, #70, #71, #72, #73, #74, #75, #76,
#77, #78, #79, #80, #81, #82, #83, #84, #85, #86, #87, #88, #89, #90, #91,
#92, #93, #94, #95, #96, #97, #98, #99, #100, #101, #102, #103, #104, #105,
#106, #107, #108, #109, #110, #111, #112, #113, #114, #115, #116, #117,
#118, #119, #120, #121, #122, #123, #124, #125, #126, #127, #128, #129,
#130, #131, #132, #133, #134, #135, #136, #137, #138, #139, #140, #141,
#142, #143, #144, #145, #146, #147, #148, #149, #150, #151, #152, #153,
#154, #155, #156, #157, #158, #159, #160, #161, #162, #163, #164, #165,
#166, #167, #168, #169, #170, #171, #172, #173, #174, #175, #176, #177,
#178, #179, #180, #181, #182, #183, #184, #185, #186, #187, #188, #189,
#190, #191, #192, #193, #194, #195, #196, #197, #198, #199, #200, #201,
#202, #203, #204, #205, #206, #207, #208, #209, #210, #211, #212, #213,
#214, #215, #216, #217, #218, #219, #220, #221, #222, #223, #224, #225,
#226, #227, #228, #229, #230, #231, #232, #233, #234, #235, #236, #237,
#238, #239, #240, #241, #242, #243, #244, #245, #246, #247, #248, #249,
#250, #251, #252, #253, #254, #255);
NoIso88591Support: boolean = false;
threadvar
(* Temporary allocations may be performed in parallel in different threads *)
TempCpRec: TCpRec;
function OS2GetStandardCodePage (const stdcp: TStandardCodePageEnum): TSystemCodePage;
var
RC, C, RetSize: cardinal;
NoUConvObject: TUConvObject;
begin
RC := DosQueryCP (SizeOf (C), @C, RetSize);
if (RC <> 0) and (RC <> 473) then
begin
OSErrorWatch (RC);
C := 850;
end
else
if RetSize < SizeOf (C) then
C := 850;
OS2GetStandardCodePage := OS2CpToRtlCp (C, cpxMappingOnly, NoUConvObject);
end;
function DummyUniCreateUConvObject (const CpName: PWideChar;
var UConv_Object: TUConvObject): longint; cdecl;
var
P: pointer;
PW, PCPN: PWideChar;
S: string [20];
C: cardinal;
L: PtrInt;
I: longint;
A: array [0..7] of char;
CPN2: UnicodeString;
RC, RetSize: cardinal;
begin
UConv_Object := nil;
if (CpName = nil) or (CpName^ = #0) then
begin
RC := DosQueryCP (SizeOf (C), @C, RetSize);
if (RC <> 0) and (RC <> 473) then
begin
C := 850;
OSErrorWatch (RC);
end;
Str (C, CPN2); (* Str should hopefully not use this function recurrently *)
L := Length (CPN2);
Insert (IBMPrefix, CPN2, 1);
PCPN := @CPN2 [1];
end
else
begin
PCPN := CpName;
for I := 0 to 7 do
if I mod 2 = 0 then
A [I] := UpCase (PChar (@PCPN [0]) [I])
else
A [I] := PChar (@PCPN [0]) [I];
if PQWord (@A)^ <> PQWord (@IBMPrefix)^ then
begin
DummyUniCreateUConvObject := Uls_Invalid;
Exit;
end;
L := 0;
PW := PCPN + 4;
while ((PW + L)^ <> #0) and (L <= SizeOf (S)) do
begin
S [Succ (L)] := char (Ord ((PW + L)^));
Inc (L);
end;
if L > SizeOf (S) then
begin
DummyUniCreateUConvObject := Uls_Other;
Exit;
end;
SetLength (S, L);
Val (S, C, I);
if I <> 0 then
begin
DummyUniCreateUConvObject := Uls_Invalid;
Exit;
end;
end;
Inc (L);
GetMem (P, SizeOf (TDummyUConvObject) + (L + 4) * 2);
if P = nil then
DummyUniCreateUConvObject := Uls_NoMemory
else
begin
DummyUniCreateUConvObject := Uls_Success;
PDummyUConvObject (P)^.CP := C;
PDummyUConvObject (P)^.CpNameLen := Pred (L) + 4;
Move (PCPN [0], PDummyUConvObject (P)^.CpName, (L + 4) * 2);
UConv_Object := TUConvObject (P);
end;
end;
function DummyUniFreeUConvObject (UConv_Object: TUConvObject): longint; cdecl;
begin
if UConv_Object <> nil then
FreeMem (UConv_Object, SizeOf (TDummyUConvObject) +
Succ (PDummyUConvObject (UConv_Object)^.CpNameLen) * 2);
DummyUniFreeUConvObject := Uls_Success;
end;
function DummyUniMapCpToUcsCp (const Codepage: cardinal;
CodepageName: PWideChar; const N: cardinal): longint; cdecl;
var
S: UnicodeString;
RC, CP, RetSize: cardinal;
begin
if Codepage = 0 then
begin
RC := DosQueryCP (SizeOf (CP), @CP, RetSize);
if (RC <> 0) and (RC <> 473) then
begin
CP := 850;
OSErrorWatch (RC);
end;
Str (CP, S);
end
else
Str (Codepage, S);
if (N <= Length (S) + 4) or (CodepageName = nil) then
DummyUniMapCptoUcsCp := Uls_Invalid
else
begin
Move (IBMPrefix, CodepageName^, SizeOf (IBMPrefix));
Move (S [1], CodepageName [4], Length (S) * SizeOf (WideChar));
CodepageName [Length (S) + 4] := #0;
DummyUniMapCpToUcsCp := Uls_Success;
end;
end;
function DummyUniUConvFromUcs (UConv_Object: TUConvObject;
var UcsBuf: PWideChar; var UniCharsLeft: longint; var OutBuf: PChar;
var OutBytesLeft: longint; var NonIdentical: longint): longint; cdecl;
var
Dest, Dest2: RawByteString;
NoUConvObj: TUConvObject;
RtlCp: TSystemCodepage;
UcsLen: PtrInt;
begin
if UConv_Object = nil then
RtlCp := OS2GetStandardCodePage (scpAnsi)
else
RtlCp := OS2CpToRtlCp (PDummyUConvObject (UConv_Object)^.CP, cpxMappingOnly,
NoUConvObj);
DefaultUnicode2AnsiMove (UcsBuf, Dest, RtlCp, UniCharsLeft);
NonIdentical := 1; { Assume at least one substitution with dummy implementation }
if Length (Dest) > OutBytesLeft then
begin
UcsLen := 1;
repeat
DefaultUnicode2AnsiMove (UcsBuf, Dest2, RtlCp, UcsLen);
if Length (Dest2) <= OutBytesLeft then
begin
Dest := Dest2;
end;
Inc (UcsLen);
until Length (Dest2) > OutBytesLeft;
Dec (UcsLen);
Inc (UcsBuf, UcsLen);
Dec (UniCharsLeft, UcsLen);
DummyUniUConvFromUcs := Uls_BufferFull;
end
else
begin
Inc (UcsBuf, UniCharsLeft);
UniCharsLeft := 0;
DummyUniUConvFromUcs := Uls_Success;
end;
Move (Dest [1], OutBuf^, Length (Dest));
Inc (OutBuf, Length (Dest));
Dec (OutBytesLeft, Length (Dest));
end;
function DummyUniUConvToUcs (UConv_Object: TUConvObject; var InBuf: PChar;
var InBytesLeft: longint; var UcsBuf: PWideChar; var UniCharsLeft: longint;
var NonIdentical: longint): longint; cdecl;
var
Dest, Dest2: UnicodeString;
NoUConvObj: TUConvObject;
RtlCp: TSystemCodepage;
SrcLen: PtrInt;
begin
if UConv_Object = nil then
RtlCp := OS2GetStandardCodePage (scpAnsi)
else
RtlCp := OS2CpToRtlCp (PDummyUConvObject (UConv_Object)^.CP, cpxMappingOnly,
NoUConvObj);
DefaultAnsi2UnicodeMove (InBuf, RtlCp, Dest, InBytesLeft);
NonIdentical := 0; { Assume no need for substitutions in this direction }
if Length (Dest) > UniCharsLeft then
begin
SrcLen := 1;
repeat
DefaultAnsi2UnicodeMove (InBuf, RtlCp, Dest2, SrcLen);
if Length (Dest2) <= UniCharsLeft then
begin
Dest := Dest2;
end;
Inc (SrcLen);
until Length (Dest2) > UniCharsLeft;
Dec (SrcLen);
Inc (InBuf, SrcLen);
Dec (InBytesLeft, SrcLen);
DummyUniUConvToUcs := Uls_BufferFull; { According to IBM documentation Uls_Invalid and not Uls_BufferFull is returned by UniUConvFromUcs?! }
end
else
begin
Inc (InBuf, InBytesLeft); { Shall it be increased in case of success too??? }
InBytesLeft := 0;
DummyUniUConvToUcs := Uls_Success;
end;
Move (Dest [1], UcsBuf^, Length (Dest) * 2);
Inc (UcsBuf, Length (Dest)); { Shall it be increased in case of success too??? }
Dec (UniCharsLeft, Length (Dest));
end;
function DummyUniMapCtryToLocale (CountryCode: cardinal; LocaleName: PWideChar;
BufSize: longint): longint; cdecl;
begin
if BufSize = 0 then
DummyUniMapCtryToLocale := Uls_Invalid
else
begin
LocaleName^ := #0;
DummyUniMapCtryToLocale := Uls_Unsupported;
end;
end;
procedure InitDBCSLeadRanges;
var
RC: cardinal;
begin
RC := DosQueryDBCSEnv (SizeOf (DBCSLeadRanges), EmptyCC,
@DBCSLeadRanges [0]);
DBCSLeadRangesEnd := 0;
if RC <> 0 then
while (DBCSLeadRangesEnd < SizeOf (DBCSLeadRanges)) and
((DBCSLeadRanges [DBCSLeadRangesEnd] <> #0) or
(DBCSLeadRanges [Succ (DBCSLeadRangesEnd)] <> #0)) do
Inc (DBCSLeadRangesEnd, 2);
end;
procedure InitDummyAnsiSupport;
var
C: char;
AllChars: array [char] of char;
RetSize: cardinal;
begin
if DosQueryCollate (SizeOf (CollationSequence), EmptyCC, @CollationSequence,
RetSize) <> 0 then
Move (LowerChars, CollationSequence, SizeOf (CollationSequence));
Move (LowerChars, AllChars, SizeOf (AllChars));
if DosMapCase (SizeOf (AllChars), IsoCC, @AllChars [#0]) <> 0 then
(* Codepage 819 may not be supported in all old OS/2 versions. *)
begin
Move (LowerCharsIso88591, AllChars, SizeOf (AllChars));
DosMapCase (SizeOf (AllChars), EmptyCC, @AllChars [#0]);
NoIso88591Support := true;
end;
for C := Low (char) to High (char) do
if AllChars [C] <> C then
LowerCharsIso88591 [AllChars [C]] := C;
if NoIso88591Support then
Move (LowerCharsIso88591, LowerChars, SizeOf (LowerChars))
else
begin
Move (LowerChars, AllChars, SizeOf (AllChars));
DosMapCase (SizeOf (AllChars), EmptyCC, @AllChars [#0]);
for C := Low (char) to High (char) do
if AllChars [C] <> C then
LowerChars [AllChars [C]] := C;
end;
InitDBCSLeadRanges;
end;
procedure ReInitDummyAnsiSupport;
var
C: char;
AllChars: array [char] of char;
RetSize: cardinal;
begin
for C := Low (char) to High (char) do
AllChars [C] := C;
if DosQueryCollate (SizeOf (CollationSequence), EmptyCC, @CollationSequence,
RetSize) <> 0 then
Move (AllChars, CollationSequence, SizeOf (CollationSequence));
DosMapCase (SizeOf (AllChars), EmptyCC, @AllChars [#0]);
for C := Low (char) to High (char) do
if AllChars [C] <> C then
LowerChars [AllChars [C]] := C;
InitDBCSLeadRanges;
end;
function DummyUniToLower (UniCharIn: WideChar): WideChar; cdecl;
var
C: char;
begin
C := UniCharIn;
DummyUniToLower := LowerCharsIso88591 [C];
end;
function DummyUniToUpper (UniCharIn: WideChar): WideChar; cdecl;
var
C: char;
begin
DummyUniToUpper := UniCharIn;
C := UniCharIn;
if NoIso88591Support then
begin
if DosMapCase (1, EmptyCC, @C) = 0 then
DummyUniToUpper := C;
end
else
if DosMapCase (1, IsoCC, @C) = 0 then
DummyUniToUpper := C
end;
function DummyUniStrColl (Locale_Object: TLocaleObject;
const UCS1, UCS2: PWideChar): longint; cdecl;
var
S1, S2: ansistring;
begin
S1 := UCS1;
S2 := UCS2;
if S1 = S2 then
DummyUniStrColl := 0
else if S1 < S2 then
DummyUniStrColl := -1
else
DummyUniStrColl := 1;
end;
function DummyUniCreateLocaleObject (LocaleSpecType: longint;
const LocaleSpec: pointer; var Locale_Object: TLocaleObject): longint; cdecl;
begin
DummyUniCreateLocaleObject := ULS_Unsupported;
end;
function DummyUniFreeLocaleObject (Locale_Object: TLocaleObject): longint;
cdecl;
begin
DummyUniFreeLocaleObject := ULS_BadObject;
end;
const
CpXList: TCpXList = (
(WinCP: CP_UTF8; OS2CP: 1208; UConvObj: nil),
(WinCP: CP_ASCII; OS2CP: 367; UConvObj: nil),
(WinCP: 28597; OS2CP: 813; UConvObj: nil),
(WinCP: 28591; OS2CP: 819; UConvObj: nil),
(WinCP: 28592; OS2CP: 912; UConvObj: nil),
(WinCP: 28593; OS2CP: 913; UConvObj: nil),
(WinCP: 28594; OS2CP: 914; UConvObj: nil),
(WinCP: 28595; OS2CP: 915; UConvObj: nil),
(WinCP: 28598; OS2CP: 916; UConvObj: nil),
(WinCP: 28599; OS2CP: 920; UConvObj: nil),
(WinCP: 28603; OS2CP: 921; UConvObj: nil),
(WinCP: 28605; OS2CP: 923; UConvObj: nil),
(WinCP: 10000; OS2CP: 1275; UConvObj: nil),
(WinCP: 10006; OS2CP: 1280; UConvObj: nil),
(WinCP: 10081; OS2CP: 1281; UConvObj: nil),
(WinCP: 10029; OS2CP: 1282; UConvObj: nil),
(WinCP: 10007; OS2CP: 1283; UConvObj: nil),
(WinCP: 20273; OS2CP: 273; UConvObj: nil),
(WinCP: 20277; OS2CP: 277; UConvObj: nil),
(WinCP: 20278; OS2CP: 278; UConvObj: nil),
(WinCP: 20280; OS2CP: 280; UConvObj: nil),
(WinCP: 20284; OS2CP: 284; UConvObj: nil),
(WinCP: 20285; OS2CP: 285; UConvObj: nil),
(WinCP: 20290; OS2CP: 290; UConvObj: nil),
(WinCP: 20297; OS2CP: 297; UConvObj: nil),
(WinCP: 20420; OS2CP: 420; UConvObj: nil),
(WinCP: 20424; OS2CP: 424; UConvObj: nil),
(WinCP: 20833; OS2CP: 833; UConvObj: nil),
(WinCP: 20838; OS2CP: 838; UConvObj: nil),
(WinCP: 20866; OS2CP: 878; UConvObj: nil),
(WinCP: 737; OS2CP: 851; UConvObj: nil),
(WinCP: 20924; OS2CP: 924; UConvObj: nil),
(WinCP: 20932; OS2CP: 932; UConvObj: nil),
(WinCP: 20936; OS2CP: 936; UConvObj: nil),
(WinCP: 21025; OS2CP: 1025; UConvObj: nil),
(WinCP: CP_UTF16; OS2CP: CP_UTF16; UConvObj: nil),
(WinCP: 37; OS2CP: 37; UConvObj: nil),
(WinCP: 437; OS2CP: 437; UConvObj: nil),
(WinCP: 500; OS2CP: 500; UConvObj: nil),
(WinCP: 850; OS2CP: 850; UConvObj: nil),
(WinCP: 852; OS2CP: 852; UConvObj: nil),
(WinCP: 855; OS2CP: 855; UConvObj: nil),
(WinCP: 857; OS2CP: 857; UConvObj: nil),
(WinCP: 860; OS2CP: 860; UConvObj: nil),
(WinCP: 861; OS2CP: 861; UConvObj: nil),
(WinCP: 862; OS2CP: 862; UConvObj: nil),
(WinCP: 863; OS2CP: 863; UConvObj: nil),
(WinCP: 864; OS2CP: 864; UConvObj: nil),
(WinCP: 865; OS2CP: 865; UConvObj: nil),
(WinCP: 866; OS2CP: 866; UConvObj: nil),
(WinCP: 869; OS2CP: 869; UConvObj: nil),
(WinCP: 870; OS2CP: 870; UConvObj: nil),
(WinCP: 874; OS2CP: 874; UConvObj: nil),
(WinCP: 875; OS2CP: 875; UConvObj: nil),
(WinCP: 949; OS2CP: 949; UConvObj: nil),
(WinCP: 950; OS2CP: 950; UConvObj: nil),
(WinCP: 1026; OS2CP: 1026; UConvObj: nil),
(WinCP: 1047; OS2CP: 1047; UConvObj: nil),
(WinCP: 1140; OS2CP: 1140; UConvObj: nil),
(WinCP: 1141; OS2CP: 1141; UConvObj: nil),
(WinCP: 1142; OS2CP: 1142; UConvObj: nil),
(WinCP: 1143; OS2CP: 1143; UConvObj: nil),
(WinCP: 1144; OS2CP: 1144; UConvObj: nil),
(WinCP: 1145; OS2CP: 1145; UConvObj: nil),
(WinCP: 1146; OS2CP: 1146; UConvObj: nil),
(WinCP: 1147; OS2CP: 1147; UConvObj: nil),
(WinCP: 1148; OS2CP: 1148; UConvObj: nil),
(WinCP: 1149; OS2CP: 1149; UConvObj: nil),
(WinCP: 1250; OS2CP: 1250; UConvObj: nil),
(WinCP: 1251; OS2CP: 1251; UConvObj: nil),
(WinCP: 1252; OS2CP: 1252; UConvObj: nil),
(WinCP: 1253; OS2CP: 1253; UConvObj: nil),
(WinCP: 1254; OS2CP: 1254; UConvObj: nil),
(WinCP: 1255; OS2CP: 1255; UConvObj: nil),
(WinCP: 1256; OS2CP: 1256; UConvObj: nil),
(WinCP: 1257; OS2CP: 1257; UConvObj: nil)
);
(* Possibly add index tables for both directions and binary search??? *)
{
function GetRtlCpFromCpRec (const CpRec: TCpRec): TSystemCodepage; inline;
begin
if RtlUsesWinCp then
GetRtlCp := CpRec.WinCP
else
GetRtlCp := TSystemCodepage (CpRec.Os2Cp);
end;
}
function UConvObjectForCP (CP: cardinal; var UConvObj: TUConvObject): longint;
var
RC: longint;
A: array [0..12] of WideChar;
begin
UConvObj := nil;
RC := Sys_UniMapCpToUcsCp (CP, @A, 12);
if RC = 0 then
RC := Sys_UniCreateUconvObject (@A, UConvObj);
{$WARNING: TODO: Deallocate some previously allocated UConvObj and try again if failed}
UConvObjectForCP := RC;
if RC <> 0 then
OSErrorWatch (RC);
end;
procedure InitDefaultCP;
var
OS2CP, I: cardinal;
NoUConvObj: TUConvObject;
RCI: longint;
RC: cardinal;
CPArr: TCPArray;
ReturnedSize: cardinal;
WA: array [0..9] of WideChar; (* Even just 6 WideChars should be enough *)
CI: TCountryInfo;
begin
if InInitDefaultCP <> -1 then
begin
repeat
DosSleep (5);
until InInitDefaultCP <> -1;
Exit;
end;
InInitDefaultCP := ThreadID;
if DefCpRec.UConvObj <> nil then
begin
(* Do not free the UConv object from DefCpRec, because it is also stored in
the respective CPXList record! *)
{
RCI := Sys_UniFreeUConvObject (DefCpRec.UConvObj);
if RCI <> 0 then
OSErrorWatch (cardinal (RCI));
}
DefCpRec.UConvObj := nil;
end;
RC := DosQueryCP (SizeOf (CPArr), @CPArr, ReturnedSize);
if (RC <> 0) and (RC <> 473) then
begin
OSErrorWatch (RC);
CPArr [0] := 850;
end
else if (ReturnedSize < 4) then
CPArr [0] := 850;
DefaultFileSystemCodePage := OS2CPtoRtlCP (CPArr [0], cpxAll,
DefCpRec.UConvObj);
CachedDefFSCodepage := DefaultFileSystemCodePage;
DefCpRec.OS2CP := CPArr [0];
(* Find out WinCP _without_ considering RtlUsesWinCP *)
I := 1;
while (I <= MaxNonEqualCPMapping) and (CpXList [I].OS2CP <> DefCpRec.OS2CP)
do
Inc (I);
if CpXList [I].OS2CP = CPArr [0] then
DefCpRec.WinCP := CpXList [I].WinCP
else
DefCpRec.WinCP := CPArr [0];
if DefLocObj <> nil then
begin
RCI := Sys_UniFreeLocaleObject (DefLocObj);
if RCI <> 0 then
OSErrorWatch (cardinal (RCI));
DefLocObj := nil;
end;
if UniAPI then (* Do not bother with the locale object otherwise *)
begin
RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WNull, DefLocObj);
if RCI <> 0 then
begin
OSErrorWatch (cardinal (RCI));
DefLocObj := nil;
(* The locale dependent routines like comparison require a valid locale *)
(* setting, but the locale set using environment variable LANG is not *)
(* recognized by OS/2 -> let's try to derive the locale from country *)
RC := DosQueryCtryInfo (SizeOf (CI), EmptyCC, CI, ReturnedSize);
if RC = 0 then
begin
RCI := Sys_UniMapCtryToLocale (CI.Country, @WA [0],
SizeOf (WA) div SizeOf (WideChar));
if RCI = 0 then
begin
RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WA [0],
DefLocObj);
if RCI <> 0 then
begin
OSErrorWatch (cardinal (RCI));
DefLocObj := nil;
end;
end
else
OSErrorWatch (cardinal (RCI));
end
else
OSErrorWatch (RC);
if DefLocObj = nil then
(* Still no success -> let's use the "Universal" locale as a fallback. *)
begin
RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WUniv [0],
DefLocObj);
if RCI <> 0 then
begin
OSErrorWatch (cardinal (RCI));
DefLocObj := nil;
end;
end;
end;
end
else (* not UniAPI *)
ReInitDummyAnsiSupport;
InInitDefaultCP := -1;
end;
function OS2CPtoRtlCP (CP: cardinal; ReqFlags: byte;
var UConvObj: TUConvObject): TSystemCodepage;
var
I, I2: cardinal;
RCI: longint;
function CheckDefaultOS2CP: boolean;
begin
if CP = DefCpRec.OS2CP then
begin
CheckDefaultOS2CP := true;
if RTLUsesWinCP then
OS2CPtoRtlCP := DefCpRec.WinCP;
if ReqFlags and CpxMappingOnly = 0 then
UConvObj := DefCpRec.UConvObj;
end
else
CheckDefaultOS2CP := false;
end;
begin
OS2CPtoRtlCP := TSystemCodePage (CP);
UConvObj := nil;
if not UniAPI then (* No UniAPI => no need for UConvObj *)
ReqFlags := ReqFlags or CpxMappingOnly;
if CheckDefaultOS2CP then
Exit;
if (CachedDefFSCodepage <> DefaultFileSystemCodePage) and
(InInitDefaultCP <> ThreadID) then
(* InInitDefaultCP = ThreadID -> this thread is already re-initializing the cached information *)
begin
if InInitDefaultCP <> -1 then
repeat
DosSleep (5) (* Let's wait until the other thread finishes re-initialization of the cache *)
until InInitDefaultCP = -1
else
InitDefaultCP;
if CheckDefaultOS2CP then
Exit;
end;
I := 1;
if ReqFlags and CpxSpecial = CpxSpecial then
I2 := 2
else
if ReqFlags and CpxMappingOnly = CpxMappingOnly then
I2 := MaxNonEqualCPMapping
else
I2 := MaxCPMapping;
while I <= I2 do
begin
if CP = CpXList [I].OS2CP then
begin
if RTLUsesWinCP then
OS2CPtoRtlCP := CpXList [I].WinCP;
if ReqFlags and CpxMappingOnly = 0 then
begin
if CpXList [I].UConvObj = nil then
begin
if UConvObjectForCP (CpXList [I].OS2CP, UConvObj) = Uls_Success then
CpXList [I].UConvObj := UConvObj
else
UConvObj := nil;
end
else
UConvObj := CpXList [I].UConvObj;
end;
Exit;
end;
Inc (I);
end;
(* If codepage was not found in the translation table and UConvObj is
requested, allocate one in the temporary record. *)
if ReqFlags and CpxMappingOnly = 0 then
begin
if TempCpRec.OS2CP = CP then
UConvObj := TempCpRec.UConvObj
else
begin
if TempCpRec.UConvObj <> nil then
begin
RCI := Sys_UniFreeUConvObject (TempCpRec.UConvObj);
if RCI <> 0 then
OSErrorWatch (cardinal (RCI));
TempCpRec.UConvObj := nil;
end;
if UConvObjectForCP (CP, UConvObj) = Uls_Success then
begin
TempCpRec.UConvObj := UConvObj;
TempCpRec.OS2CP := CP;
end
else
UConvObj := nil;
end;
end;
end;
function RtlCPtoOS2CP (RtlCP: TSystemCodepage; ReqFlags: byte;
var UConvObj: TUConvObject): cardinal;
var
I, I2: cardinal;
function CheckDefaultWinCP: boolean;
begin
if RtlCP = DefCpRec.WinCP then
begin
CheckDefaultWinCP := true;
RtlCPtoOS2CP := DefCpRec.WinCP;
if ReqFlags and CpxMappingOnly = 0 then
UConvObj := DefCpRec.UConvObj;
end
else
CheckDefaultWinCP := false;
end;
begin
RtlCPtoOS2CP := RtlCP;
UConvObj := nil;
if not UniAPI then (* No UniAPI => no need for UConvObj *)
ReqFlags := ReqFlags or CpxMappingOnly;
if not (RTLUsesWinCP) then
begin
if ReqFlags and CpxMappingOnly = 0 then
OS2CPtoRtlCP (cardinal (RtlCp), ReqFlags, UConvObj);
end
else if CheckDefaultWinCp then
Exit
else
begin
if (CachedDefFSCodepage <> DefaultFileSystemCodePage) and
(InInitDefaultCP <> ThreadID) then
(* InInitDefaultCP = ThreadID -> this thread is already re-initializing the cached information *)
begin
if InInitDefaultCP <> -1 then
repeat
(* Let's wait until the other thread finishes re-initialization of the cache *)
DosSleep (5)
until InInitDefaultCP = -1
else
InitDefaultCP;
if CheckDefaultWinCP then
Exit;
end;
I := 1;
if ReqFlags and CpxSpecial = CpxSpecial then
I2 := 2
else
if ReqFlags and CpxMappingOnly = CpxMappingOnly then
I2 := MaxNonEqualCPMapping
else
I2 := MaxCPMapping;
while I <= I2 do
begin
if RtlCP = CpXList [I].WinCP then
begin
RtlCPtoOS2CP := CpXList [I].OS2CP;
if ReqFlags and CpxMappingOnly = 0 then
begin
begin
if UConvObjectForCP (CpXList [I].OS2CP, UConvObj) = Uls_Success then
CpXList [I].UConvObj := UConvObj
else
UConvObj := nil;
end
end;
Exit;
end;
Inc (I);
end;
(*
Special processing for
ExceptionWinCodepages = (CP_UTF16BE, CP_UTF7, 12000 {UTF32}, 12001 {UTF32BE})
might be added here...or not ;-)
if (TempCpRec.OS2CP <> High (TempCpRec.OS2CP)) or
(TempCpRec.WinCP <> RtlCp) then
begin
if TempCpRec.UConvObj <> nil then
begin
RCI := Sys_UniFreeUConvObject (TempCpRec.UConvObj);
if RCI <> 0 then
OSErrorWatch (cardinal (RCI));
end;
TempCpRec.OS2CP := High (TempCpRec.OS2CP);
TempCpRec.WinCP := RtlCp;
end;
Map to CP_ASCII aka OS2CP=367 if RtlCP not recognized and UConvObject
is requested???
*)
(* Signalize unrecognized (untranslatable) MS Windows codepage *)
OSErrorWatch (Uls_Invalid);
end;
end;
function OS2CPtoRtlCP (CP: cardinal; ReqFlags: byte): TSystemCodepage;
var
NoUConvObj: TUConvObject;
begin
if RtlUsesWinCP then
OS2CPtoRtlCP := OS2CPtoRtlCP (CP, ReqFlags or CpxMappingOnly, NoUConvObj)
else
OS2CPtoRtlCP := TSystemCodepage (CP);
end;
function RtlCPtoOS2CP (RtlCP: TSystemCodepage; ReqFlags: byte): cardinal;
var
NoUConvObj: TUConvObject;
begin
if RtlUsesWinCP then
RtlCPtoOS2CP := RtlCPtoOS2CP (RtlCP, ReqFlags or CpxMappingOnly, NoUConvObj)
else
RtlCPtoOS2CP := RtlCP;
end;
procedure OS2Unicode2AnsiMove (Source: PUnicodeChar; var Dest: RawByteString;
CP: TSystemCodePage; Len: SizeInt);
var
RCI: longint;
UConvObj: TUConvObject;
OS2CP: cardinal;
Src2: PUnicodeChar;
Len2, LenOut, OutOffset, NonIdentical: longint;
Dest2: PChar;
begin
OS2CP := RtlCpToOS2CP (CP, CpxAll, UConvObj);
{ if UniAPI and (UConvObj = nil) then - OS2Unicode2AnsiMove should be never called if not UniAPI }
if UConvObj = nil then
begin
{$WARNING Special cases like UTF-7 should be handled here, otherwise signalize error - how???}
DefaultUnicode2AnsiMove (Source, Dest, CP, Len);
Exit;
end;
LenOut := Succ (Len); (* Standard OS/2 CP is a SBCS *)
SetLength (Dest, LenOut);
SetCodePage (Dest, CP, false);
Src2 := Source;
Len2 := Len;
Dest2 := PChar (Dest);
RCI := Sys_UniUConvFromUcs (UConvObj, Src2, Len2, Dest2, LenOut,
NonIdentical);
repeat
case RCI of
Uls_Success:
begin
if LenOut > 0 then
SetLength (Dest, Length (Dest) - LenOut);
Break;
end;
Uls_IllegalSequence:
begin
OSErrorWatch (Uls_IllegalSequence);
{ skip and set to '?' }
Inc (Src2);
Dec (Len2);
Dest2^ := '?';
Inc (Dest2);
Dec (LenOut);
end;
Uls_BufferFull:
begin
OutOffset := Dest2 - PChar (Dest);
(* Use Len2 or Len decreased by difference between Source and Src2? *)
(* Extend more this time - target is probably a DBCS or UTF-8 *)
SetLength (Dest, Length (Dest) + Succ (Len2 * 2));
{ string could have been moved }
Dest2 := PChar (Dest) + OutOffset;
Inc (LenOut, Succ (Len2 * 2));
end
else
begin
SetLength (Dest, 0);
OSErrorWatch (cardinal (RCI));
{ Break }
RunError (231);
end;
end;
RCI := Sys_UniUConvFromUcs (UConvObj, Src2, Len2, Dest2, LenOut,
NonIdentical);
until false;
end;
procedure OS2Ansi2UnicodeMove (Source: PChar; CP: TSystemCodePage;
var Dest: UnicodeString; Len: SizeInt);
var
RCI: longint;
UConvObj: TUConvObject;
OS2CP: cardinal;
Src2: PChar;
Len2, LenOut, OutOffset, NonIdentical: longint;
Dest2: PWideChar;
begin
OS2CP := RtlCpToOS2CP (CP, CpxAll, UConvObj);
{ if UniAPI and (UConvObj = nil) then - OS2Unicode2AnsiMove should be never called if not UniAPI }
if UConvObj = nil then
begin
{$WARNING Special cases like UTF-7 should be handled here, otherwise signalize error - how???}
DefaultAnsi2UnicodeMove (Source, CP, Dest, Len);
Exit;
end;
LenOut := Succ (Len); (* Standard OS/2 CP is a SBCS *)
SetLength (Dest, LenOut);
Src2 := Source;
Len2 := Len;
Dest2 := PWideChar (Dest);
RCI := Sys_UniUConvToUcs (UConvObj, Src2, Len2, Dest2, LenOut, NonIdentical);
repeat
case RCI of
Uls_Success:
begin
if LenOut > 0 then
SetLength (Dest, Length (Dest) - LenOut);
Break;
end;
Uls_IllegalSequence:
begin
OSErrorWatch (Uls_IllegalSequence);
{ skip and set to '?' }
Inc (Src2);
Dec (Len2);
Dest2^ := '?';
Inc (Dest2);
Dec (LenOut);
end;
Uls_BufferFull:
begin
OutOffset := Dest2 - PWideChar (Dest);
(* Use Len2 or Len decreased by difference between Source and Src2? *)
SetLength (Dest, Length (Dest) + Succ (Len2));
{ string could have been moved }
Dest2 := PWideChar (Dest) + OutOffset;
Inc (LenOut, Succ (Len2));
end
else
begin
SetLength (Dest, 0);
OSErrorWatch (cardinal (RCI));
{ Break }
RunError (231);
end;
end;
RCI := Sys_UniUConvToUcs (UConvObj, Src2, Len2, Dest2, LenOut,
NonIdentical);
until false;
end;
function RtlChangeCP (CP: TSystemCodePage): longint;
var
OS2CP, I: cardinal;
NoUConvObj: TUConvObject;
RCI: longint;
begin
OS2CP := RtlCpToOS2Cp (CP, cpxMappingOnly, NoUConvObj);
RtlChangeCP := longint (DosSetProcessCP (OS2CP));
if RtlChangeCP <> 0 then
OSErrorWatch (RtlChangeCP)
else
begin
DefaultSystemCodePage := CP;
DefaultRTLFileSystemCodePage := DefaultSystemCodePage;
DefaultFileSystemCodePage := DefaultSystemCodePage;
if OS2CP <> DefCpRec.OS2CP then
begin
if DefCpRec.UConvObj <> nil then
begin
(* Do not free the UConv object from DefCpRec, because it is also stored in
the respective CpXList record! *)
{
RCI := Sys_UniFreeUConvObject (DefCpRec.UConvObj);
if RCI <> 0 then
OSErrorWatch (cardinal (RCI));
}
DefCpRec.UConvObj := nil;
end;
DefCPRec.OS2CP := OS2CP;
RCI := Sys_UniCreateUConvObject (@WNull, DefCpRec.UConvObj);
if RCI <> 0 then
OSErrorWatch (cardinal (RCI));
(* Find out WinCP _without_ considering RtlUsesWinCP *)
I := 1;
while (I <= MaxNonEqualCPMapping) and (CpXList [I].OS2CP <> OS2CP) do
Inc (I);
if CpXList [I].OS2CP = OS2CP then
DefCpRec.WinCP := CpXList [I].WinCP
else
DefCpRec.WinCP := OS2CP;
end;
end;
end;
function OS2UpperUnicodeString (const S: UnicodeString): UnicodeString;
var
I: cardinal;
begin
SetLength (Result, Length (S));
if Length (S) > 0 then
for I := 0 to Pred (Length (S)) do
PWideChar (Result) [I] := Sys_UniToUpper (S [Succ (I)]);
end;
function OS2LowerUnicodeString (const S: UnicodeString): UnicodeString;
var
I: cardinal;
begin
SetLength (Result, Length (S));
if Length (S) > 0 then
for I := 0 to Pred (Length (S)) do
PWideChar (Result) [I] := Sys_UniToLower (S [Succ (I)]);
end;
function NoNullsUnicodeString (const S: UnicodeString): UnicodeString;
var
I: cardinal;
begin
Result := S;
UniqueString (Result);
if Length (S) > 0 then
for I := 1 to Length (S) do
if Result [I] = WNull then
Result [I] := ' ';
end;
function OS2CompareUnicodeString (const S1, S2: UnicodeString; Options : TCompareOptions): PtrInt;
var
HS1, HS2: UnicodeString;
begin
{ UniStrColl interprets null chars as end-of-string -> filter out }
HS1 := NoNullsUnicodeString (S1);
HS2 := NoNullsUnicodeString (S2);
(*
if coLingIgnoreCase in Options then
begin
HS1:=OS2UpperUnicodeString(HS1);
HS2:=OS2UpperUnicodeString(HS2);
{$WARNING TODO: Exclude null characters and convert to uppercase in one-pass}
end
else
*)
if coIgnoreCase in Options then
begin
HS1:=OS2UpperUnicodeString(HS1);
HS2:=OS2UpperUnicodeString(HS2);
{$WARNING TODO: Exclude null characters and convert to uppercase in one-pass}
end;
Result := Sys_UniStrColl (DefLocObj, PWideChar (HS1), PWideChar (HS2));
if Result < -1 then
Result := -1
else if Result > 1 then
Result := 1;
end;
(*
function OS2CompareTextUnicodeString (const S1, S2: UnicodeString): PtrInt;
begin
Result := OS2CompareUnicodeString (OS2UpperUnicodeString (S1),
OS2UpperUnicodeString (S2));
{$WARNING Language independent uppercase routine may not be appropriate for language dependent case insensitive comparison!}
end;
*)
function OS2UpperAnsiString (const S: AnsiString): AnsiString;
var
RC: cardinal;
begin
Result := S;
UniqueString (Result);
FillChar (EmptyCC, SizeOf (EmptyCC), 0);
RC := DosMapCase (Length (Result), EmptyCC, PChar (Result));
{ What to do in case of a failure??? }
if RC <> 0 then
Result := UpCase (S); { Use a fallback? }
end;
function OS2LowerAnsiString (const S: AnsiString): AnsiString;
var
I: PtrUInt;
function IsDBCSLeadChar (C: char): boolean;
var
D: byte;
begin
IsDBCSLeadChar := false;
D := 0;
while D < DBCSLeadRangesEnd do
begin
if (C >= DBCSLeadRanges [D]) and (C <= DBCSLeadRanges [Succ (D)]) then
begin
IsDBCSLeadChar := true;
Exit;
end;
Inc (D, 2);
end;
end;
begin
(*
OS/2 provides no direct solution for lowercase conversion of MBCS strings.
If Unicode support is available, using Unicode routines is the best solution.
If not, we use a translation table built at startup by translating the full
character set to uppercase and using that for creation of a lookup table
(as already done in sysutils). However, we need to check for DBCS (MBCS)
codepages and avoid translating the DBCS lead bytes and the following
character.
*)
if UniAPI then
Result := AnsiString (OS2LowerUnicodeString (UnicodeString (S)))
else
begin
Result := S;
if Length (Result) > 0 then
begin
UniqueString (Result);
if DBCSLeadRangesEnd > 0 then
begin
I := 1;
while I <= Length (Result) do
begin
if IsDBCSLeadChar (Result [I]) then
Inc (I, 2)
else
begin
Result [I] := LowerChars [Result [I]];
Inc (I);
end;
end;
end
else
for I := 1 to Length (Result) do
Result [I] := LowerChars [Result [I]];
end;
end;
end;
function OS2CompareStrAnsiString (const S1, S2: AnsiString): PtrInt;
var
I, MaxLen: PtrUInt;
begin
if UniAPI then
Result := OS2CompareUnicodeString (UnicodeString (S1), UnicodeString (S2),
[])
else
(* Older OS/2 versions without Unicode support do not provide direct means *)
(* for case sensitive and codepage and language-aware string comparison. *)
(* We have to resort to manual comparison of the original strings together *)
(* with strings translated using the case insensitive collation sequence. *)
begin
if Length (S1) = 0 then
begin
if Length (S2) = 0 then
Result := 0
else
Result := -1;
Exit;
end
else
if Length (S2) = 0 then
begin
Result := 1;
Exit;
end;
I := 1;
MaxLen := Length (S1);
if Length (S2) < MaxLen then
MaxLen := Length (S2);
repeat
if CollationSequence [S1 [I]] = CollationSequence [S2 [I]] then
begin
if S1 [I] < S2 [I] then
begin
Result := -1;
Exit;
end
else if S1 [I] > S2 [I] then
begin
Result := 1;
Exit;
end;
end
else
begin
if CollationSequence [S1 [I]] < CollationSequence [S2 [I]] then
Result := -1
else
Result := 1;
Exit;
end;
Inc (I);
until (I > MaxLen);
if Length (S2) > MaxLen then
Result := -1
else if Length (S1) > MaxLen then
Result := 1
else
Result := 0;
end;
end;
function OS2StrCompAnsiString (S1, S2: PChar): PtrInt;
var
HSA1, HSA2: AnsiString;
HSU1, HSU2: UnicodeString;
begin
(* Do not call OS2CompareUnicodeString to skip scanning for #0. *)
HSA1 := AnsiString (S1);
HSA2 := AnsiString (S2);
if UniApi then
begin
HSU1 := UnicodeString (HSA1);
HSU2 := UnicodeString (HSA2);
Result := Sys_UniStrColl (DefLocObj, PWideChar (HSU1), PWideChar (HSU2));
if Result < -1 then
Result := -1
else if Result > 1 then
Result := 1;
end
else
Result := OS2CompareStrAnsiString (HSA1, HSA2);
end;
function OS2CompareTextAnsiString (const S1, S2: AnsiString): PtrInt;
var
HSA1, HSA2: AnsiString;
I: PtrUInt;
begin
if UniAPI then
Result := OS2CompareUnicodeString (UnicodeString (S1), UnicodeString (S2),
[coIgnoreCase])
else
begin
(* Let's use collation strings here as a fallback *)
SetLength (HSA1, Length (S1));
if Length (HSA1) > 0 then
(* Using assembler would be much faster, but never mind... *)
for I := 1 to Length (HSA1) do
HSA1 [I] := CollationSequence [S1 [I]];
{$WARNING Results of using collation sequence with DBCS not known/tested!}
SetLength (HSA2, Length (S2));
if Length (HSA2) > 0 then
for I := 1 to Length (HSA2) do
HSA2 [I] := CollationSequence [S2 [I]];
if HSA1 = HSA2 then
Result := 0
else if HSA1 < HSA2 then
Result := -1
else
Result := 1;
end;
end;
function OS2StrICompAnsiString (S1, S2: PChar): PtrInt;
begin
Result := OS2CompareTextAnsiString (AnsiString (S1), AnsiString (S2));
end;
function OS2StrLCompAnsiString (S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
var
A, B: AnsiString;
begin
if (MaxLen = 0) then
Exit (0);
SetLength (A, MaxLen);
Move (S1^, A [1], MaxLen);
SetLength (B, MaxLen);
Move (S2^, B [1], MaxLen);
Result := OS2CompareStrAnsiString (A, B);
end;
function OS2StrLICompAnsiString (S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
var
A, B: AnsiString;
begin
if (MaxLen = 0) then
Exit (0);
SetLength (A, MaxLen);
Move (S1^, A [1], MaxLen);
SetLength (B, MaxLen);
Move (S2^, B [1], MaxLen);
Result := OS2CompareTextAnsiString (A, B);
end;
procedure FPC_RangeError; [external name 'FPC_RANGEERROR'];
procedure Ansi2PChar (const S: AnsiString; const OrgP: PChar; out P: Pchar);
var
NewLen: SizeUInt;
begin
NewLen := Length (S);
if NewLen > StrLen (OrgP) then
FPC_RangeError;
P := OrgP;
if (NewLen > 0) then
Move (S [1], P [0], NewLen);
P [NewLen] := #0;
end;
function OS2StrUpperAnsiString (Str: PChar): PChar;
var
Temp: AnsiString;
begin
Temp := OS2UpperAnsiString (Str);
Ansi2PChar (Temp, Str, Result);
end;
function OS2StrLowerAnsiString (Str: PChar): PChar;
var
Temp: AnsiString;
begin
Temp := OS2LowerAnsiString (Str);
Ansi2PChar (Temp, Str, Result);
end;
(*
CWSTRING:
{ return value: number of code points in the string. Whenever an invalid
code point is encountered, all characters part of this invalid code point
are considered to form one "character" and the next character is
considered to be the start of a new (possibly also invalid) code point }
function CharLengthPChar(const Str: PChar): PtrInt;
var
nextlen: ptrint;
s: pchar;
{$ifndef beos}
mbstate: mbstate_t;
{$endif not beos}
begin
result:=0;
s:=str;
{$ifndef beos}
fillchar(mbstate,sizeof(mbstate),0);
{$endif not beos}
repeat
{$ifdef beos}
nextlen:=ptrint(mblen(s,MB_CUR_MAX));
{$else beos}
nextlen:=ptrint(mbrlen(s,MB_CUR_MAX,@mbstate));
{$endif beos}
{ skip invalid/incomplete sequences }
if (nextlen<0) then
nextlen:=1;
inc(result,1);
inc(s,nextlen);
until (nextlen=0);
end;
function CodePointLength(const Str: PChar; maxlookahead: ptrint): PtrInt;
var
nextlen: ptrint;
{$ifndef beos}
mbstate: mbstate_t;
{$endif not beos}
begin
{$ifdef beos}
result:=ptrint(mblen(str,maxlookahead));
{$else beos}
fillchar(mbstate,sizeof(mbstate),0);
result:=ptrint(mbrlen(str,maxlookahead,@mbstate));
{ mbrlen can also return -2 for "incomplete but potially valid character
and data has been processed" }
if result<0 then
result:=-1;
{$endif beos}
end;
*)
procedure InitOS2WideStringManager; inline;
var
RC: cardinal;
ErrName: array [0..MaxPathLen] of char;
P: pointer;
begin
RC := DosLoadModule (@ErrName [0], SizeOf (ErrName), @UConvName [0],
UConvHandle);
if RC = 0 then
begin
RC := DosQueryProcAddr (UConvHandle, OrdUniCreateUConvObject, nil, P);
if RC = 0 then
begin
Sys_UniCreateUConvObject := TUniCreateUConvObject (P);
RC := DosQueryProcAddr (UConvHandle, OrdUniMapCpToUcsCp, nil, P);
if RC = 0 then
begin
Sys_UniMapCpToUcsCp := TUniMapCpToUcsCp (P);
RC := DosQueryProcAddr (UConvHandle, OrdUniFreeUConvObject, nil, P);
if RC = 0 then
begin
Sys_UniFreeUConvObject := TUniFreeUConvObject (P);
RC := DosQueryProcAddr (UConvHandle, OrdUniUConvFromUcs, nil, P);
if RC = 0 then
begin
Sys_UniUConvFromUcs := TUniUConvFromUcs (P);
RC := DosQueryProcAddr (UConvHandle, OrdUniUConvToUcs, nil, P);
if RC = 0 then
begin
Sys_UniUConvToUcs := TUniUConvToUcs (P);
RC := DosLoadModule (@ErrName [0], SizeOf (ErrName),
@LibUniName [0], LibUniHandle);
if RC = 0 then
begin
RC := DosQueryProcAddr (LibUniHandle, OrdUniToLower, nil, P);
if RC = 0 then
begin
Sys_UniToLower := TUniToLower (P);
RC := DosQueryProcAddr (LibUniHandle, OrdUniToUpper, nil, P);
if RC = 0 then
begin
Sys_UniToUpper := TUniToUpper (P);
RC := DosQueryProcAddr (LibUniHandle, OrdUniStrColl, nil,
P);
if RC = 0 then
begin
Sys_UniStrColl := TUniStrColl (P);
RC := DosQueryProcAddr (LibUniHandle,
OrdUniCreateLocaleObject, nil, P);
if RC = 0 then
begin
Sys_UniCreateLocaleObject := TUniCreateLocaleObject
(P);
RC := DosQueryProcAddr (LibUniHandle,
OrdUniFreeLocaleObject, nil, P);
if RC = 0 then
begin
Sys_UniFreeLocaleObject := TUniFreeLocaleObject (P);
RC := DosQueryProcAddr (LibUniHandle,
OrdUniMapCtryToLocale, nil, P);
if RC = 0 then
begin
Sys_UniMapCtryToLocale := TUniMapCtryToLocale (P);
UniAPI := true;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
if RC <> 0 then
OSErrorWatch (RC);
if not (UniAPI) then
begin
Sys_UniCreateUConvObject := @DummyUniCreateUConvObject;
Sys_UniMapCpToUcsCp := @DummyUniMapCpToUcsCp;
Sys_UniFreeUConvObject := @DummyUniFreeUConvObject;
Sys_UniUConvFromUcs := @DummyUniUConvFromUcs;
Sys_UniUConvToUcs := @DummyUniUConvToUcs;
Sys_UniToLower := @DummyUniToLower;
Sys_UniToUpper := @DummyUniToUpper;
Sys_UniStrColl := @DummyUniStrColl;
Sys_UniCreateLocaleObject := @DummyUniCreateLocaleObject;
Sys_UniFreeLocaleObject := @DummyUniFreeLocaleObject;
Sys_UniMapCtryToLocale := @DummyUniMapCtryToLocale;
InitDummyAnsiSupport;
end;
{ Widestring }
WideStringManager.Wide2AnsiMoveProc := @OS2Unicode2AnsiMove;
WideStringManager.Ansi2WideMoveProc := @OS2Ansi2UnicodeMove;
WideStringManager.UpperWideStringProc := @OS2UpperUnicodeString;
WideStringManager.LowerWideStringProc := @OS2LowerUnicodeString;
WideStringManager.CompareWideStringProc := @OS2CompareUnicodeString;
{ Unicode }
WideStringManager.Unicode2AnsiMoveProc := @OS2Unicode2AnsiMove;
WideStringManager.Ansi2UnicodeMoveProc := @OS2Ansi2UnicodeMove;
WideStringManager.UpperUnicodeStringProc := @OS2UpperUnicodeString;
WideStringManager.LowerUnicodeStringProc := @OS2LowerUnicodeString;
WideStringManager.CompareUnicodeStringProc := @OS2CompareUnicodeString;
{ Codepage }
WideStringManager.GetStandardCodePageProc := @OS2GetStandardCodePage;
(*
CharLengthPCharProc:=@CharLengthPChar;
CodePointLengthProc:=@CodePointLength;
*)
WideStringManager.UpperAnsiStringProc := @OS2UpperAnsiString;
WideStringManager.LowerAnsiStringProc := @OS2LowerAnsiString;
WideStringManager.CompareStrAnsiStringProc := @OS2CompareStrAnsiString;
WideStringManager.CompareTextAnsiStringProc := @OS2CompareTextAnsiString;
WideStringManager.StrCompAnsiStringProc := @OS2StrCompAnsiString;
WideStringManager.StrICompAnsiStringProc := @OS2StrICompAnsiString;
WideStringManager.StrLCompAnsiStringProc := @OS2StrLCompAnsiString;
WideStringManager.StrLICompAnsiStringProc := @OS2StrLICompAnsiString;
WideStringManager.StrLowerAnsiStringProc := @OS2StrLowerAnsiString;
WideStringManager.StrUpperAnsiStringProc := @OS2StrUpperAnsiString;
end;
Reference in New Issue View Git Blame Copy Permalink