diff options
Diffstat (limited to 'rtl/os2/sysucode.inc')
| -rw-r--r-- | rtl/os2/sysucode.inc | 1654 |
1 files changed, 1654 insertions, 0 deletions
diff --git a/rtl/os2/sysucode.inc b/rtl/os2/sysucode.inc new file mode 100644 index 0000000000..422a3d1ea7 --- /dev/null +++ b/rtl/os2/sysucode.inc @@ -0,0 +1,1654 @@ +{ + 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; + + + +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); (* Empty = current *) + (* 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 as 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; + + +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; +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 <> 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)); + end; + RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WNull, DefLocObj); + if RCI <> 0 then + OSErrorWatch (cardinal (RCI)); + if not (UniAPI) then + 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)); + 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)); + 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)); + 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); + for I := 1 to Length (S) do + if Result [I] = WNull then + Result [I] := ' '; +end; + + +function OS2CompareUnicodeString (const S1, S2: UnicodeString): PtrInt; +var + HS1, HS2: UnicodeString; +begin + { UniStrColl interprets null chars as end-of-string -> filter out } + HS1 := NoNullsUnicodeString (S1); + HS2 := NoNullsUnicodeString (S2); + 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 := OS2LowerUnicodeString (S) +{ Two implicit conversions... ;-) } + 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 (S1, S2) (* implicit conversions *) + 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 := HSA1; (* implicit conversion *) + HSU2 := HSA2; (* implicit conversion *) + 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 := OS2CompareTextUnicodeString (S1, S2) (* implicit conversions *) + 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); + + UniAPI := true; + 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; + InitDummyAnsiSupport; + end; + + { Widestring } + WideStringManager.Wide2AnsiMoveProc := @OS2Unicode2AnsiMove; + WideStringManager.Ansi2WideMoveProc := @OS2Ansi2UnicodeMove; + WideStringManager.UpperWideStringProc := @OS2UpperUnicodeString; + WideStringManager.LowerWideStringProc := @OS2LowerUnicodeString; + WideStringManager.CompareWideStringProc := @OS2CompareUnicodeString; + WideStringManager.CompareTextWideStringProc := @OS2CompareTextUnicodeString; + { Unicode } + WideStringManager.Unicode2AnsiMoveProc := @OS2Unicode2AnsiMove; + WideStringManager.Ansi2UnicodeMoveProc := @OS2Ansi2UnicodeMove; + WideStringManager.UpperUnicodeStringProc := @OS2UpperUnicodeString; + WideStringManager.LowerUnicodeStringProc := @OS2LowerUnicodeString; + WideStringManager.CompareUnicodeStringProc := @OS2CompareUnicodeString; + WideStringManager.CompareTextUnicodeStringProc := + @OS2CompareTextUnicodeString; + { 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; |