diff --git a/.gitattributes b/.gitattributes index b169655f1b..017a0bee34 100644 --- a/.gitattributes +++ b/.gitattributes @@ -9004,6 +9004,7 @@ rtl/os2/sysos2.pas svneol=native#text/plain rtl/os2/sysosh.inc svneol=native#text/plain rtl/os2/system.pas svneol=native#text/plain rtl/os2/systhrd.inc svneol=native#text/plain +rtl/os2/sysucode.inc svneol=native#text/plain rtl/os2/sysutils.pp svneol=native#text/plain rtl/os2/tests/atx.pas svneol=native#text/plain rtl/os2/tests/basicpm.pas svneol=native#text/plain diff --git a/rtl/os2/sysos.inc b/rtl/os2/sysos.inc index 0c23595f6a..6f448610c4 100644 --- a/rtl/os2/sysos.inc +++ b/rtl/os2/sysos.inc @@ -79,7 +79,7 @@ procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock; external 'DOSCALLS' index 312; function DosLoadModule (ObjName: PChar; ObjLen: cardinal; DLLName: PChar; - var Handle: cardinal): cardinal; cdecl; + var Handle: THandle): cardinal; cdecl; external 'DOSCALLS' index 318; function DosQueryModuleHandle (DLLName: PChar; var Handle: THandle): cardinal; @@ -428,3 +428,6 @@ type function DosQueryCP (Size: cardinal; CodePages: PCPArray; var ActSize: cardinal): cardinal; cdecl; external 'DOSCALLS' index 291; + +function DosSetProcessCP (CP: cardinal): cardinal; cdecl; +external 'DOSCALLS' index 289; diff --git a/rtl/os2/system.pas b/rtl/os2/system.pas index 2488c07c45..733386f710 100644 --- a/rtl/os2/system.pas +++ b/rtl/os2/system.pas @@ -27,6 +27,7 @@ interface {$endif SYSTEMDEBUG} {$DEFINE OS2EXCEPTIONS} +{$DEFINE OS2UNICODE} {$define DISABLE_NO_THREAD_MANAGER} {$DEFINE HAS_GETCPUCOUNT} @@ -51,23 +52,29 @@ const RealMaxPathLen: word = MaxPathLen; (* Default value only - real value queried from the system on startup. *) -type Tos=(osDOS,osOS2,osDPMI); +type + TOS = (osDOS, osOS2, osDPMI); (* For compatibility with target EMX *) + TUConvObject = pointer; -const OS_Mode: Tos = osOS2; - First_Meg: pointer = nil; +const + OS_Mode: TOS = osOS2; (* For compatibility with target EMX *) + First_Meg: pointer = nil; (* For compatibility with target EMX *) -const UnusedHandle=-1; - StdInputHandle=0; - StdOutputHandle=1; - StdErrorHandle=2; + UnusedHandle=-1; + StdInputHandle=0; + StdOutputHandle=1; + StdErrorHandle=2; - LFNSupport: boolean = true; - FileNameCaseSensitive: boolean = false; - FileNameCasePreserving: boolean = true; - CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *) + LFNSupport: boolean = true; + FileNameCaseSensitive: boolean = false; + FileNameCasePreserving: boolean = true; + CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *) + RTLUsesWinCP: boolean = true; (* UnicodeString manager shall treat *) +(* codepage numbers passed to RTL functions as those used under MS Windows *) +(* and translates them to their OS/2 equivalents if necessary. *) - sLineBreak = LineEnding; - DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF; + sLineBreak = LineEnding; + DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF; var { C-compatible arguments and environment } @@ -90,40 +97,61 @@ var ApplicationType: cardinal; const - HeapAllocFlags: cardinal = $53; (* Compatible to VP/2 *) - (* mfPag_Commit or mfObj_Tile or mfPag_Write or mfPag_Read *) + HeapAllocFlags: cardinal = $53; (* Compatible to VP/2 *) + (* mfPag_Commit or mfObj_Tile or mfPag_Write or mfPag_Read *) function ReadUseHighMem: boolean; procedure WriteUseHighMem (B: boolean); -(* Is allocation of memory above 512 MB address limit allowed? Initialized *) -(* during initialization of system unit according to capabilities of the *) -(* underlying OS/2 version, can be overridden by user - heap is allocated *) -(* for all threads, so the setting isn't declared as a threadvar and *) -(* should be only changed at the beginning of the main thread if needed. *) +(* Is allocation of memory above 512 MB address limit allowed? Even if use *) +(* of high memory is supported by the underlying OS/2 version, just a subset *) +(* of OS/2 API functions can work with memory buffers located in high *) +(* memory. Since FPC RTL allocates heap using memory pools received from *) +(* the operating system and thus memory allocation from the operating system *) +(* may happen at a different time than allocation of memory from FPC heap, *) +(* use of high memory shall be enabled only if the given program is ensured *) +(* not to use any OS/2 API function beyond the limited set supporting it any *) +(* time between enabling this feature and program termination. *) property UseHighMem: boolean read ReadUseHighMem write WriteUseHighMem; (* UseHighMem is provided for compatibility with 2.0.x. *) + +{$IFDEF OS2UNICODE} +function OS2CPtoRtlCP (CP: cardinal; ReqFlags: byte; + var UConvObj: TUConvObject): TSystemCodepage; + +function RtlCPtoOS2CP (RtlCP: TSystemCodepage; ReqFlags: byte; + var UConvObj: TUConvObject): cardinal; + +function OS2CPtoRtlCP (CP: cardinal; ReqFlags: byte): TSystemCodepage; + +function RtlCPtoOS2CP (RtlCP: TSystemCodepage; ReqFlags: byte): cardinal; + +function RtlChangeCP (CP: TSystemCodePage): longint; +{$ENDIF OS2UNICODE} + + const (* Are file sizes > 2 GB (64-bit) supported on the current system? *) FSApi64: boolean = false; + UniAPI: boolean = false; (* Support for tracking I/O errors returned by OS/2 API calls - emulation *) (* of GetLastError / fpGetError functionality used e.g. in Sysutils. *) type - TOSErrorWatch = procedure (Error: cardinal); + TOSErrorWatch = procedure (Error: cardinal); procedure NoErrorTracking (Error: cardinal); (* This shall be invoked whenever a non-zero error is returned by OS/2 APIs *) (* used in the RTL. Direct OS/2 API calls in user programs are not covered! *) const - OSErrorWatch: TOSErrorWatch = @NoErrorTracking; + OSErrorWatch: TOSErrorWatch = @NoErrorTracking; -procedure SetOSErrorTracking (P: pointer); +function SetOSErrorTracking (P: pointer): pointer; procedure SetDefaultOS2FileType (FType: ShortString); @@ -141,22 +169,44 @@ type TDosSetFileSizeL = function (Handle: THandle; Size: int64): cardinal; cdecl; -function DummyDosOpenL (FileName: PChar; var Handle: THandle; - var Action: cardinal; InitSize: int64; - Attrib, OpenFlags, FileMode: cardinal; - EA: pointer): cardinal; cdecl; + TUniCreateUConvObject = function (const CpName: PWideChar; + var UConv_Object: TUConvObject): longint; cdecl; -function DummyDosSetFilePtrL (Handle: THandle; Pos: int64; Method: cardinal; - var PosActual: int64): cardinal; cdecl; + TUniFreeUConvObject = function (UConv_Object: TUConvObject): longint; cdecl; + + TUniMapCpToUcsCp = function (const Codepage: cardinal; + CodepageName: PWideChar; const N: cardinal): longint; cdecl; + + TUniUConvFromUcs = function (UConv_Object: TUConvObject; + var UcsBuf: PWideChar; var UniCharsLeft: longint; var OutBuf: PChar; + var OutBytesLeft: longint; var NonIdentical: longint): longint; cdecl; + + TUniUConvToUcs = function (UConv_Object: TUConvObject; var InBuf: PChar; + var InBytesLeft: longint; var UcsBuf: PWideChar; var UniCharsLeft: longint; + var NonIdentical: longint): longint; cdecl; -function DummyDosSetFileSizeL (Handle: THandle; Size: int64): cardinal; cdecl; const - Sys_DosOpenL: TDosOpenL = @DummyDosOpenL; - Sys_DosSetFilePtrL: TDosSetFilePtrL = @DummyDosSetFilePtrL; - Sys_DosSetFileSizeL: TDosSetFileSizeL = @DummyDosSetFileSizeL; DosCallsHandle: THandle = THandle (-1); +{$IFDEF OS2UNICODE} + UConvHandle: THandle = THandle (-1); + LibUniHandle: THandle = THandle (-1); +{$ENDIF OS2UNICODE} + + +var + Sys_DosOpenL: TDosOpenL; + Sys_DosSetFilePtrL: TDosSetFilePtrL; + Sys_DosSetFileSizeL: TDosSetFileSizeL; +{$IFDEF OS2UNICODE} + Sys_UniCreateUConvObject: TUniCreateUConvObject; + Sys_UniFreeUConvObject: TUniFreeUConvObject; + Sys_UniMapCpToUcsCp: TUniMapCpToUcsCp; + Sys_UniUConvFromUcs: TUniUConvFromUcs; + Sys_UniUConvToUcs: TUniUConvToUcs; +{$ENDIF OS2UNICODE} + implementation @@ -571,6 +621,7 @@ var RC: cardinal; begin RC := DosUnsetExceptionHandler (ExcptReg^); + OSErrorWatch (RC); end; {$ENDIF OS2EXCEPTIONS} @@ -880,8 +931,9 @@ begin end; -procedure SetOSErrorTracking (P: pointer); +function SetOSErrorTracking (P: pointer): pointer; begin + SetOSErrorTracking := OSErrorWatch; if P = nil then OSErrorWatch := @NoErrorTracking else @@ -891,7 +943,7 @@ end; procedure InitEnvironment; var env_count : longint; - dos_env,cp : pchar; + cp : pchar; begin env_count:=0; cp:=environment; @@ -938,12 +990,12 @@ var RC: cardinal; procedure allocarg(idx,len: PtrInt); - var - oldargvlen : PtrInt; +{ var + oldargvlen : PtrInt;} begin if idx>=argvlen then begin - oldargvlen:=argvlen; +{ oldargvlen:=argvlen;} argvlen:=(idx+8) and (not 7); sysreallocmem(argv,argvlen*sizeof(pointer)); { fillchar(argv[oldargvlen],(argvlen-oldargvlen)*sizeof(pointer),0);} @@ -1222,6 +1274,9 @@ begin from the high memory region before changing value of this variable. *) InitHeap; + Sys_DosOpenL := @DummyDosOpenL; + Sys_DosSetFilePtrL := @DummyDosSetFilePtrL; + Sys_DosSetFileSizeL := @DummyDosSetFileSizeL; RC := DosQueryModuleHandle (@DosCallsName [0], DosCallsHandle); if RC = 0 then begin @@ -1269,9 +1324,31 @@ begin fpc_cpucodeinit; InitUnicodeStringManager; -{$ifdef OS2UCODE} - InitOS2WideStrings; -{$endif OS2UCODE} + +{$IFDEF OS2UNICODE} + InitOS2WideStringManager; +{$ENDIF OS2UNICODE} + + 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; +{$IFDEF OS2UNICODE} + DefaultSystemCodePage := OS2CPtoRtlCP (CPArr [0], cpxMappingOnly, + DefCpRec.UConvObj); + DefCpRec.OS2CP := CPArr [0]; + DefCpRec.WinCP := DefaultSystemCodePage; + Sys_UniCreateUconvObject (@WNull, DefCpRec.UConvObj); +{$ELSE OS2UNICODE} + DefaultSystemCodePage := CPArr [0]; +{$ENDIF OS2UNICODE} + DefaultRTLFileSystemCodePage := DefaultSystemCodePage; + DefaultFileSystemCodePage := DefaultSystemCodePage; + DefaultUnicodeCodePage := CP_UTF16; { ... and I/O } SysInitStdIO; @@ -1298,17 +1375,4 @@ begin WriteLn (StdErr, 'Old exception ', HexStr (OldExceptAddr, 8), ', new exception ', HexStr (NewExceptAddr, 8), ', _SS = ', HexStr (_SS, 8)); {$endif SYSTEMEXCEPTIONDEBUG} - - RC := DosQueryCP (SizeOf (CPArr), @CPArr, ReturnedSize); - if (RC <> 0) and (RC <> 473) then - OSErrorWatch (RC) - else if (ReturnedSize >= 4) then - begin - DefaultSystemCodePage := CPArr [0]; - DefaultRTLFileSystemCodePage := DefaultSystemCodePage; - DefaultFileSystemCodePage := DefaultSystemCodePage; - DefaultUnicodeCodePage := CP_UTF16; - end - else - OSErrorWatch (RC); end. diff --git a/rtl/os2/sysucode.inc b/rtl/os2/sysucode.inc new file mode 100644 index 0000000000..2cd59cbb13 --- /dev/null +++ b/rtl/os2/sysucode.inc @@ -0,0 +1,1348 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2014 by Tomas Hajny, + member 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_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; + 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; + TLocaleObject = pointer; + TDummyUConvObject = record + CP: cardinal; + CPNameLen: byte; + CPName: record end; + end; + PDummyUConvObject = ^TDummyUConvObject; + +const + DefCpRec: TCpRec = (WinCP: 0; OS2CP: 0; UConvObj: nil); + IBMPrefix: packed array [1..4] of WideChar = 'IBM-'; + +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; + 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; + + + +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 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; + + +function OS2CPtoRtlCP (CP: cardinal; ReqFlags: byte; + var UConvObj: TUConvObject): TSystemCodepage; +var + I, I2: cardinal; + RCI: longint; +begin + OS2CPtoRtlCP := TSystemCodePage (CP); + UConvObj := nil; + if not UniAPI then (* No UniAPI => no need for UConvObj *) + ReqFlags := ReqFlags or CpxMappingOnly; + if CP = DefCpRec.OS2CP then + begin + if RTLUsesWinCP then + OS2CPtoRtlCP := DefCpRec.WinCP; + if ReqFlags and CpxMappingOnly = 0 then + UConvObj := DefCpRec.UConvObj; + end + else + begin + 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; +end; + + +function RtlCPtoOS2CP (RtlCP: TSystemCodepage; ReqFlags: byte; + var UConvObj: TUConvObject): cardinal; +var + I, I2: cardinal; +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 RtlCP = DefCpRec.WinCP then + begin + RtlCPtoOS2CP := DefCpRec.WinCP; + if ReqFlags and CpxMappingOnly = 0 then + UConvObj := DefCpRec.UConvObj; + end + else + begin + 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; + +{??? + PUnicodeRec(pointer(dest)-UnicodeFirstOff)^.CodePage:=CP_UTF16; +} +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 + 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 Win32UnicodeUpper(const s : UnicodeString) : UnicodeString; + begin + result:=s; + UniqueString(result); + if length(result)>0 then + CharUpperBuff(LPWSTR(result),length(result)); + end; + + +function Win32UnicodeLower(const s : UnicodeString) : UnicodeString; + begin + result:=s; + UniqueString(result); + if length(result)>0 then + CharLowerBuff(LPWSTR(result),length(result)); + end; +} + + +(* +CWSTRING: + +function LowerWideString(const s : WideString) : WideString; + var + i : SizeInt; + begin + SetLength(result,length(s)); + for i:=0 to length(s)-1 do + pwidechar(result)[i]:=WideChar(towlower(wint_t(s[i+1]))); + end; + + +function UpperWideString(const s : WideString) : WideString; + var + i : SizeInt; + begin + SetLength(result,length(s)); + for i:=0 to length(s)-1 do + pwidechar(result)[i]:=WideChar(towupper(wint_t(s[i+1]))); + end; + + +procedure EnsureAnsiLen(var S: AnsiString; const len: SizeInt); inline; +begin + if (len>length(s)) then + if (length(s) < 10*256) then + setlength(s,length(s)+10) + else + setlength(s,length(s)+length(s) shr 8); +end; + + +procedure ConcatCharToAnsiStr(const c: char; var S: AnsiString; var index: SizeInt); +begin + EnsureAnsiLen(s,index); + pchar(@s[index])^:=c; + inc(index); +end; + + +{ concatenates an utf-32 char to a widestring. S *must* be unique when entering. } +{$ifndef beos} +procedure ConcatUTF32ToAnsiStr(const nc: wint_t; var S: AnsiString; var index: SizeInt; var mbstate: mbstate_t); +{$else not beos} +procedure ConcatUTF32ToAnsiStr(const nc: wint_t; var S: AnsiString; var index: SizeInt); +{$endif beos} +var + p : pchar; + mblen : size_t; +begin + { we know that s is unique -> avoid uniquestring calls} + p:=@s[index]; + if (nc<=127) then + ConcatCharToAnsiStr(char(nc),s,index) + else + begin + EnsureAnsiLen(s,index+MB_CUR_MAX); +{$ifndef beos} + mblen:=wcrtomb(p,wchar_t(nc),@mbstate); +{$else not beos} + mblen:=wctomb(p,wchar_t(nc)); +{$endif not beos} + if (mblen<>size_t(-1)) then + inc(index,mblen) + else + begin + { invalid wide char } + p^:='?'; + inc(index); + end; + end; +end; + + +function LowerAnsiString(const s : AnsiString) : AnsiString; + var + i, slen, + resindex : SizeInt; + mblen : size_t; +{$ifndef beos} + ombstate, + nmbstate : mbstate_t; +{$endif beos} + wc : wchar_t; + begin +{$ifndef beos} + fillchar(ombstate,sizeof(ombstate),0); + fillchar(nmbstate,sizeof(nmbstate),0); +{$endif beos} + slen:=length(s); + SetLength(result,slen+10); + i:=1; + resindex:=1; + while (i<=slen) do + begin + if (s[i]<=#127) then + begin + wc:=wchar_t(s[i]); + mblen:= 1; + end + else +{$ifndef beos} + mblen:=mbrtowc(@wc, pchar(@s[i]), slen-i+1, @ombstate); +{$else not beos} + mblen:=mbtowc(@wc, pchar(@s[i]), slen-i+1); +{$endif not beos} + case mblen of + size_t(-2): + begin + { partial invalid character, copy literally } + while (i<=slen) do + begin + ConcatCharToAnsiStr(s[i],result,resindex); + inc(i); + end; + end; + size_t(-1), 0: + begin + { invalid or null character } + ConcatCharToAnsiStr(s[i],result,resindex); + inc(i); + end; + else + begin + { a valid sequence } + { even if mblen = 1, the lowercase version may have a } + { different length } + { We can't do anything special if wchar_t is 16 bit... } +{$ifndef beos} + ConcatUTF32ToAnsiStr(towlower(wint_t(wc)),result,resindex,nmbstate); +{$else not beos} + ConcatUTF32ToAnsiStr(towlower(wint_t(wc)),result,resindex); +{$endif not beos} + inc(i,mblen); + end; + end; + end; + SetLength(result,resindex-1); + end; + + +function UpperAnsiString(const s : AnsiString) : AnsiString; + var + i, slen, + resindex : SizeInt; + mblen : size_t; +{$ifndef beos} + ombstate, + nmbstate : mbstate_t; +{$endif beos} + wc : wchar_t; + begin +{$ifndef beos} + fillchar(ombstate,sizeof(ombstate),0); + fillchar(nmbstate,sizeof(nmbstate),0); +{$endif beos} + slen:=length(s); + SetLength(result,slen+10); + i:=1; + resindex:=1; + while (i<=slen) do + begin + if (s[i]<=#127) then + begin + wc:=wchar_t(s[i]); + mblen:= 1; + end + else +{$ifndef beos} + mblen:=mbrtowc(@wc, pchar(@s[i]), slen-i+1, @ombstate); +{$else not beos} + mblen:=mbtowc(@wc, pchar(@s[i]), slen-i+1); +{$endif beos} + case mblen of + size_t(-2): + begin + { partial invalid character, copy literally } + while (i<=slen) do + begin + ConcatCharToAnsiStr(s[i],result,resindex); + inc(i); + end; + end; + size_t(-1), 0: + begin + { invalid or null character } + ConcatCharToAnsiStr(s[i],result,resindex); + inc(i); + end; + else + begin + { a valid sequence } + { even if mblen = 1, the uppercase version may have a } + { different length } + { We can't do anything special if wchar_t is 16 bit... } +{$ifndef beos} + ConcatUTF32ToAnsiStr(towupper(wint_t(wc)),result,resindex,nmbstate); +{$else not beos} + ConcatUTF32ToAnsiStr(towupper(wint_t(wc)),result,resindex); +{$endif not beos} + inc(i,mblen); + end; + end; + end; + SetLength(result,resindex-1); + end; + + +function utf16toutf32(const S: WideString; const index: SizeInt; out len: longint): UCS4Char; external name 'FPC_UTF16TOUTF32'; + +function WideStringToUCS4StringNoNulls(const s : WideString) : UCS4String; + var + i, slen, + destindex : SizeInt; + len : longint; + uch : UCS4Char; + begin + slen:=length(s); + setlength(result,slen+1); + i:=1; + destindex:=0; + while (i<=slen) do + begin + uch:=utf16toutf32(s,i,len); + if (uch=UCS4Char(0)) then + uch:=UCS4Char(32); + result[destindex]:=uch; + inc(destindex); + inc(i,len); + end; + result[destindex]:=UCS4Char(0); + { destindex <= slen } + setlength(result,destindex+1); + end; + + +function CompareWideString(const s1, s2 : WideString) : PtrInt; + var + hs1,hs2 : UCS4String; + begin + { wcscoll interprets null chars as end-of-string -> filter out } + hs1:=WideStringToUCS4StringNoNulls(s1); + hs2:=WideStringToUCS4StringNoNulls(s2); + result:=wcscoll(pwchar_t(hs1),pwchar_t(hs2)); + end; + + +function CompareTextWideString(const s1, s2 : WideString): PtrInt; + begin + result:=CompareWideString(UpperWideString(s1),UpperWideString(s2)); + end; + + +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(str,MB_CUR_MAX)); +{$else beos} + nextlen:=ptrint(mbrlen(str,MB_CUR_MAX,@mbstate)); +{$endif beos} + { skip invalid/incomplete sequences } + if (nextlen<0) then + nextlen:=1; + inc(result,nextlen); + 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; + + +function StrCompAnsiIntern(s1,s2 : PChar; len1, len2: PtrInt; canmodifys1, canmodifys2: boolean): PtrInt; + var + a,b: pchar; + i: PtrInt; + begin + if not(canmodifys1) then + getmem(a,len1+1) + else + a:=s1; + for i:=0 to len1-1 do + if s1[i]<>#0 then + a[i]:=s1[i] + else + a[i]:=#32; + a[len1]:=#0; + + if not(canmodifys2) then + getmem(b,len2+1) + else + b:=s2; + for i:=0 to len2-1 do + if s2[i]<>#0 then + b[i]:=s2[i] + else + b[i]:=#32; + b[len2]:=#0; + result:=strcoll(a,b); + if not(canmodifys1) then + freemem(a); + if not(canmodifys2) then + freemem(b); + end; + + +function CompareStrAnsiString(const s1, s2: ansistring): PtrInt; + begin + result:=StrCompAnsiIntern(pchar(s1),pchar(s2),length(s1),length(s2),false,false); + end; + + +function StrCompAnsi(s1,s2 : PChar): PtrInt; + begin + result:=strcoll(s1,s2); + end; + + +function AnsiCompareText(const S1, S2: ansistring): PtrInt; + var + a, b: AnsiString; + begin + a:=UpperAnsistring(s1); + b:=UpperAnsistring(s2); + result:=StrCompAnsiIntern(pchar(a),pchar(b),length(a),length(b),true,true); + end; + + +function AnsiStrIComp(S1, S2: PChar): PtrInt; + begin + result:=AnsiCompareText(ansistring(s1),ansistring(s2)); + end; + + +function AnsiStrLComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt; + var + a, b: pchar; +begin + if (maxlen=0) then + exit(0); + if (s1[maxlen]<>#0) then + begin + getmem(a,maxlen+1); + move(s1^,a^,maxlen); + a[maxlen]:=#0; + end + else + a:=s1; + if (s2[maxlen]<>#0) then + begin + getmem(b,maxlen+1); + move(s2^,b^,maxlen); + b[maxlen]:=#0; + end + else + b:=s2; + result:=StrCompAnsiIntern(a,b,maxlen,maxlen,a<>s1,b<>s2); + if (a<>s1) then + freemem(a); + if (b<>s2) then + freemem(b); +end; + + +function AnsiStrLIComp(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:=AnsiCompareText(a,b); +end; + + +procedure ansi2pchar(const s: ansistring; const orgp: pchar; out p: pchar); +var + newlen: sizeint; +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 AnsiStrLower(Str: PChar): PChar; +var + temp: ansistring; +begin + temp:=loweransistring(str); + ansi2pchar(temp,str,result); +end; + + +function AnsiStrUpper(Str: PChar): PChar; +var + temp: ansistring; +begin + temp:=upperansistring(str); + ansi2pchar(temp,str,result); +end; + +{$ifdef FPC_HAS_CPSTRING} +{$i textrec.inc} +procedure SetStdIOCodePage(var T: Text); inline; +begin + case TextRec(T).Mode of + fmInput:TextRec(T).CodePage:=GetStandardCodePage(scpConsoleInput); + fmOutput:TextRec(T).CodePage:=GetStandardCodePage(scpConsoleOutput); + end; +end; + +procedure SetStdIOCodePages; inline; +begin + SetStdIOCodePage(Input); + SetStdIOCodePage(Output); + SetStdIOCodePage(ErrOutput); + SetStdIOCodePage(StdOut); + SetStdIOCodePage(StdErr); +end; +{$endif FPC_HAS_CPSTRING} +*) + +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); + + UniAPI := true; + 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; + + end; + + { Widestring } + WideStringManager.Wide2AnsiMoveProc := @OS2Unicode2AnsiMove; + WideStringManager.Ansi2WideMoveProc := @OS2Ansi2UnicodeMove; +{ WideStringManager.UpperWideStringProc := @OS2UnicodeUpper; + WideStringManager.LowerWideStringProc := @OS2UnicodeLower;} + { Unicode } + WideStringManager.Unicode2AnsiMoveProc := @OS2Unicode2AnsiMove; + WideStringManager.Ansi2UnicodeMoveProc := @OS2Ansi2UnicodeMove; +{ WideStringManager.UpperUnicodeStringProc := @OS2UnicodeUpper; + WideStringManager.LowerUnicodeStringProc := @OS2UnicodeLower;} + { Codepage } + WideStringManager.GetStandardCodePageProc := @OS2GetStandardCodePage; +(* + Wide2AnsiMoveProc:=@Wide2AnsiMove; + Ansi2WideMoveProc:=@Ansi2WideMove; + + UpperWideStringProc:=@UpperWideString; + LowerWideStringProc:=@LowerWideString; + + CompareWideStringProc:=@CompareWideString; + CompareTextWideStringProc:=@CompareTextWideString; + + CharLengthPCharProc:=@CharLengthPChar; + CodePointLengthProc:=@CodePointLength; + + UpperAnsiStringProc:=@UpperAnsiString; + LowerAnsiStringProc:=@LowerAnsiString; + CompareStrAnsiStringProc:=@CompareStrAnsiString; + CompareTextAnsiStringProc:=@AnsiCompareText; + StrCompAnsiStringProc:=@StrCompAnsi; + StrICompAnsiStringProc:=@AnsiStrIComp; + StrLCompAnsiStringProc:=@AnsiStrLComp; + StrLICompAnsiStringProc:=@AnsiStrLIComp; + StrLowerAnsiStringProc:=@AnsiStrLower; + StrUpperAnsiStringProc:=@AnsiStrUpper; + ThreadInitProc:=@InitThread; + ThreadFiniProc:=@FiniThread; + { Unicode } + Unicode2AnsiMoveProc:=@Wide2AnsiMove; + Ansi2UnicodeMoveProc:=@Ansi2WideMove; + UpperUnicodeStringProc:=@UpperWideString; + LowerUnicodeStringProc:=@LowerWideString; + CompareUnicodeStringProc:=@CompareWideString; + CompareTextUnicodeStringProc:=@CompareTextWideString; +*) +end;