* modified solution for ensuring validity of cached conversion objects

git-svn-id: trunk@29390 -

rtl/os2/system.pas

@@ -129,7 +129,7 @@ function OS2CPtoRtlCP (CP: cardinal; ReqFlags: byte): TSystemCodepage;
 
 function RtlCPtoOS2CP (RtlCP: TSystemCodepage; ReqFlags: byte): cardinal;
 
-function RtlChangeCP (CP: TSystemCodePage): longint;
+(* function RtlChangeCP (CP: TSystemCodePage; const stdcp: TStandardCodePageEnum): longint; *)
 {$ENDIF OS2UNICODE}
 
 
@@ -1207,172 +1207,165 @@ begin
   CheckInitialStkLen := StkLen;
 end;
 
-var TIB: PThreadInfoBlock;
-    RC: cardinal;
-    ErrStr: string;
-    P: pointer;
-    DW: cardinal;
-    CPArr: TCPArray;
-    ReturnedSize: cardinal;
+var
+  TIB: PThreadInfoBlock;
+  RC: cardinal;
+  P: pointer;
+  DW: cardinal;
 
 const
-    DosCallsName: array [0..8] of char = 'DOSCALLS'#0;
+  DosCallsName: array [0..8] of char = 'DOSCALLS'#0;
 
 {$IFDEF OS2UNICODE}
- {$I sysucode.inc}
+  {$I sysucode.inc}
 {$ENDIF OS2UNICODE}
 
 begin
 {$IFDEF OS2EXCEPTIONS}
-    asm
-     xorl %eax,%eax
-     movw %ss,%ax
-     movl %eax,_SS
-    end;
+  asm
+   xorl %eax,%eax
+   movw %ss,%ax
+   movl %eax,_SS
+  end;
 {$ENDIF OS2EXCEPTIONS}
-    DosGetInfoBlocks (@TIB, @PIB);
-    StackLength := CheckInitialStkLen (InitialStkLen);
-    { OS/2 has top of stack in TIB^.StackLimit - unlike Windows where it is in TIB^.Stack }
-    StackBottom := TIB^.StackLimit - StackLength;
+  DosGetInfoBlocks (@TIB, @PIB);
+  StackLength := CheckInitialStkLen (InitialStkLen);
+  { OS/2 has top of stack in TIB^.StackLimit - unlike Windows where it is in TIB^.Stack }
+  StackBottom := TIB^.StackLimit - StackLength;
 
-    {Set type of application}
-    ApplicationType := PIB^.ProcType;
-    ProcessID := PIB^.PID;
-    ThreadID := TIB^.TIB2^.TID;
-    IsConsole := ApplicationType <> 3;
+  {Set type of application}
+  ApplicationType := PIB^.ProcType;
+  ProcessID := PIB^.PID;
+  ThreadID := TIB^.TIB2^.TID;
+  IsConsole := ApplicationType <> 3;
 
-    {Query maximum path length (QSV_MAX_PATH_LEN = 1)}
-    if DosQuerySysInfo (1, 1, DW, SizeOf (DW)) = 0 then
-     RealMaxPathLen := DW;
+  {Query maximum path length (QSV_MAX_PATH_LEN = 1)}
+  if DosQuerySysInfo (1, 1, DW, SizeOf (DW)) = 0 then
+   RealMaxPathLen := DW;
 
-    ExitProc := nil;
+  ExitProc := nil;
 
 {$IFDEF OS2EXCEPTIONS}
-    Install_Exception_Handler;
+  Install_Exception_Handler;
 {$ENDIF OS2EXCEPTIONS}
 
-    (* Initialize the amount of file handles *)
-    FileHandleCount := GetFileHandleCount;
-
-    {Initialize the heap.}
-    (* Logic is following:
-       The heap is initially restricted to low address space (< 512 MB).
-       If underlying OS/2 version allows using more than 512 MB per process
-       (OS/2 WarpServer for e-Business, eComStation, possibly OS/2 Warp 4.0
-       with FP13 and above as well), use of this high memory is allowed for
-       future memory allocations at the end of System unit initialization.
-       The consequences are that the compiled application can allocate more
-       memory, but it must make sure to use direct DosAllocMem calls if it
-       needs a memory block for some system API not supporting high memory.
-       This is probably no problem for direct calls to these APIs, but
-       there might be situations when a memory block needs to be passed
-       to a 3rd party DLL which in turn calls such an API call. In case
-       of problems usage of high memory can be turned off by setting
-       UseHighMem to false - the program should change the setting at its
-       very beginning (e.g. in initialization section of the first unit
-       listed in the "uses" section) to avoid having preallocated memory
-       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);
+  (* Initialize the amount of file handles *)
+  FileHandleCount := GetFileHandleCount;
+
+  {Initialize the heap.}
+  (* Logic is following:
+     The heap is initially restricted to low address space (< 512 MB).
+     If underlying OS/2 version allows using more than 512 MB per process
+     (OS/2 WarpServer for e-Business, eComStation, possibly OS/2 Warp 4.0
+     with FP13 and above as well), use of this high memory is allowed for
+     future memory allocations at the end of System unit initialization.
+     The consequences are that the compiled application can allocate more
+     memory, but it must make sure to use direct DosAllocMem calls if it
+     needs a memory block for some system API not supporting high memory.
+     This is probably no problem for direct calls to these APIs, but
+     there might be situations when a memory block needs to be passed
+     to a 3rd party DLL which in turn calls such an API call. In case
+     of problems usage of high memory can be turned off by setting
+     UseHighMem to false - the program should change the setting at its
+     very beginning (e.g. in initialization section of the first unit
+     listed in the "uses" section) to avoid having preallocated memory
+     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
+    RC := DosQueryProcAddr (DosCallsHandle, OrdDosOpenL, nil, P);
     if RC = 0 then
      begin
-      RC := DosQueryProcAddr (DosCallsHandle, OrdDosOpenL, nil, P);
+      Sys_DosOpenL := TDosOpenL (P);
+      RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFilePtrL, nil, P);
       if RC = 0 then
        begin
-        Sys_DosOpenL := TDosOpenL (P);
-        RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFilePtrL, nil, P);
+        Sys_DosSetFilePtrL := TDosSetFilePtrL (P);
+        RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFileSizeL, nil, P);
         if RC = 0 then
          begin
-          Sys_DosSetFilePtrL := TDosSetFilePtrL (P);
-          RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFileSizeL, nil, P);
-          if RC = 0 then
-           begin
-            Sys_DosSetFileSizeL := TDosSetFileSizeL (P);
-            FSApi64 := true;
-           end;
+          Sys_DosSetFileSizeL := TDosSetFileSizeL (P);
+          FSApi64 := true;
          end;
        end;
-      if RC <> 0 then
-       OSErrorWatch (RC);
+     end;
+    if RC <> 0 then
+     OSErrorWatch (RC);
+    RC := DosQueryProcAddr (DosCallsHandle, OrdDosAllocThreadLocalMemory,
+                                                                       nil, P);
+    if RC = 0 then
+     begin
+      DosAllocThreadLocalMemory := TDosAllocThreadLocalMemory (P);
       RC := DosQueryProcAddr (DosCallsHandle, OrdDosAllocThreadLocalMemory,
                                                                        nil, P);
       if RC = 0 then
        begin
-        DosAllocThreadLocalMemory := TDosAllocThreadLocalMemory (P);
-        RC := DosQueryProcAddr (DosCallsHandle, OrdDosAllocThreadLocalMemory,
-                                                                       nil, P);
-        if RC = 0 then
-         begin
-          DosFreeThreadLocalMemory := TDosFreeThreadLocalMemory (P);
-          TLSAPISupported := true;
-         end
-        else
-         OSErrorWatch (RC);
+        DosFreeThreadLocalMemory := TDosFreeThreadLocalMemory (P);
+        TLSAPISupported := true;
        end
       else
        OSErrorWatch (RC);
      end
     else
      OSErrorWatch (RC);
+   end
+  else
+   OSErrorWatch (RC);
 
-    { ... and exceptions }
-    SysInitExceptions;
-    fpc_cpucodeinit;
+  { ... and exceptions }
+  SysInitExceptions;
+  fpc_cpucodeinit;
 
-    InitUnicodeStringManager;
+  InitUnicodeStringManager;
 
 {$IFDEF OS2UNICODE}
-    InitOS2WideStringManager;
-{$ENDIF OS2UNICODE}
+  InitOS2WideStringManager;
 
-    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);
+  InitDefaultCP;
 {$ELSE OS2UNICODE}
-    DefaultSystemCodePage := CPArr [0];
+(* Otherwise called within InitDefaultCP... *)
+  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 := CPArr [0];
 {$ENDIF OS2UNICODE}
-    DefaultRTLFileSystemCodePage := DefaultSystemCodePage;
-    DefaultFileSystemCodePage := DefaultSystemCodePage;
-    DefaultUnicodeCodePage := CP_UTF16;
+  DefaultSystemCodePage := DefaultFileSystemCodePage;
+  DefaultRTLFileSystemCodePage := DefaultFileSystemCodePage;
+  DefaultUnicodeCodePage := CP_UTF16;
 
-    { ... and I/O }
-    SysInitStdIO;
+  { ... and I/O }
+  SysInitStdIO;
 
-    { no I/O-Error }
-    inoutres:=0;
+  { no I/O-Error }
+  InOutRes:=0;
 
-    {Initialize environment (must be after InitHeap because allocates memory)}
-    Environment := pointer (PIB^.Env);
-    InitEnvironment;
+  {Initialize environment (must be after InitHeap because allocates memory)}
+  Environment := pointer (PIB^.Env);
+  InitEnvironment;
 
-    InitArguments;
+  InitArguments;
 
-    DefaultCreator := '';
-    DefaultFileType := '';
+  DefaultCreator := '';
+  DefaultFileType := '';
 
-    InitSystemThreads;
+  InitSystemThreads;
 
 {$IFDEF EXTDUMPGROW}
 {    Int_HeapSize := high (cardinal);}
 {$ENDIF EXTDUMPGROW}
 {$ifdef SYSTEMEXCEPTIONDEBUG}
- if IsConsole then
-  WriteLn (StdErr, 'Old exception ', HexStr (OldExceptAddr, 8),
+  if IsConsole then
+   WriteLn (StdErr, 'Old exception ', HexStr (OldExceptAddr, 8),
    ', new exception ', HexStr (NewExceptAddr, 8), ', _SS = ', HexStr (_SS, 8));
 {$endif SYSTEMEXCEPTIONDEBUG}
 end.

rtl/os2/sysucode.inc

@@ -91,6 +91,8 @@ type
 const
   DefCpRec: TCpRec = (WinCP: 0; OS2CP: 0; UConvObj: nil);
   IBMPrefix: packed array [1..4] of WideChar = 'IBM-';
+  CachedDefFSCodepage: TSystemCodepage = 0;
+
 
 threadvar
 (* Temporary allocations may be performed in parallel in different threads *)
@@ -107,7 +109,10 @@ begin
    begin
     OSErrorWatch (RC);
     C := 850;
-   end;
+   end
+  else
+   if RetSize < SizeOf (C) then
+    C := 850;
   OS2GetStandardCodePage := OS2CpToRtlCp (C, cpxMappingOnly, NoUConvObject);
 end;
 
@@ -397,6 +402,15 @@ const
 
 (* 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
@@ -414,78 +428,130 @@ begin
 end;
 
 
+procedure InitDefaultCP;
+var
+  OS2CP, I: cardinal;
+  NoUConvObj: TUConvObject;
+  RCI: longint;
+  RC: cardinal;
+  CPArr: TCPArray;
+  ReturnedSize: cardinal;
+begin
+  if DefCpRec.UConvObj <> nil then
+   begin
+    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], cpxMappingOnly,
+                                                            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];
+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;
+
+ 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 then
    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
+    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 CP = CpXList [I].OS2CP then
+      if RTLUsesWinCP then
+       OS2CPtoRtlCP := CpXList [I].WinCP;
+      if ReqFlags and CpxMappingOnly = 0 then
        begin
-        if RTLUsesWinCP then
-         OS2CPtoRtlCP := CpXList [I].WinCP;
-        if ReqFlags and CpxMappingOnly = 0 then
+        if CpXList [I].UConvObj = nil then
          begin
-          if CpXList [I].UConvObj = nil then
-           begin
-            if UConvObjectForCP (CpXList [I].OS2CP, UConvObj) = Uls_Success
+          if UConvObjectForCP (CpXList [I].OS2CP, UConvObj) = Uls_Success
                                                                            then
-             CpXList [I].UConvObj := UConvObj
-            else
-             UConvObj := nil;
-           end
+           CpXList [I].UConvObj := UConvObj
           else
-           UConvObj := CpXList [I].UConvObj;
-         end;
-        Exit;
+           UConvObj := nil;
+         end
+        else
+         UConvObj := CpXList [I].UConvObj;
        end;
-      Inc (I);
+      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
+  if ReqFlags and CpxMappingOnly = 0 then
+   begin
+    if TempCpRec.OS2CP = CP then
+     UConvObj := TempCpRec.UConvObj
+    else
      begin
-      if TempCpRec.OS2CP = CP then
-       UConvObj := TempCpRec.UConvObj
-      else
+      if TempCpRec.UConvObj <> nil then
        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;
+        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;
@@ -495,6 +561,20 @@ 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;
@@ -505,14 +585,16 @@ 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 if CheckDefaultWinCp then
+   Exit
   else
    begin
+    if CachedDefFSCodepage <> DefaultFileSystemCodePage then
+     begin
+      InitDefaultCP;
+      if CheckDefaultWinCP then
+       Exit;
+     end;
     I := 1;
     if ReqFlags and CpxSpecial = CpxSpecial then
      I2 := 2