paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-16 17:40:33 +01:00
Code Issues Packages Projects Releases Wiki Activity
dde2207866
fpc/rtl/os2/sysucode.inc
Tomas Hajny c3fbfcb27b * first part of UnicodeStringManager routines implementation for OS/2 
git-svn-id: trunk@29178 -
2014-11-29 01:42:29 +00:00

1349 lines
37 KiB
PHP
Raw Blame History

{
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;
Reference in New Issue View Git Blame Copy Permalink