* use the default locale for current country as the first fallback before using the 'Universal' locale if the locale set in LANG is not recognized/supported by OS/2

git-svn-id: trunk@29572 -

rtl/os2/sysos.inc

@@ -1,10 +1,9 @@
 {
     This file is part of the Free Pascal run time library.
-    Copyright (c) 2001 by Free Pascal development team
+    Copyright (c) 2001-2015 by Free Pascal development team
 
-    This file implements all the base types and limits required
+    This file contains a subset of OS/2 base types and imported OS/2 API
-    for a minimal POSIX compliant subset required to port the compiler
+    functions necessary for implementation of unit system.
-    to a new OS.
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -449,3 +448,41 @@ external 'NLS' index 6;
 function DosQueryCollate (Size: cardinal; var Country: TCountryCode;
                      Buf: PByteArray; var TableLen: cardinal): cardinal; cdecl;
 external 'NLS' index 8;
+
+type
+ TTimeFmt = (Clock12, Clock24);
+
+ TCountryInfo = record
+  Country, CodePage: cardinal;     {Country and codepage requested.}
+  DateFormat: cardinal;            {1=ddmmyy 2=yymmdd 3=mmddyy}
+  CurrencyUnit: array [0..4] of char;
+  ThousandSeparator: char;         {Thousands separator.}
+  Zero1: byte;                     {Always zero.}
+  DecimalSeparator: char;          {Decimals separator,}
+  Zero2: byte;
+  DateSeparator: char;             {Date separator.}
+  Zero3: byte;
+  TimeSeparator: char;             {Time separator.}
+  Zero4: byte;
+  CurrencyFormat,                  {Bit field:
+                                    Bit 0: 0=indicator before value
+                                           1=indicator after value
+                                    Bit 1: 1=insert space after indicator.
+                                    Bit 2: 1=Ignore bit 0&1, replace
+                                             decimal separator with
+                                             indicator.}
+  DecimalPlace: byte;              {Number of decimal places used in
+                                    currency indication.}
+  TimeFormat: TTimeFmt;            {12/24 hour.}
+  Reserve1: array [0..1] of word;
+  DataSeparator: char;             {Data list separator}
+  Zero5: byte;
+  Reserve2: array [0..4] of word;
+ end;
+
+const
+ CurrentCountry: TCountryCode = (Country: 0; CodePage: 0);
+
+function DosQueryCtryInfo (Size: cardinal; var Country: TCountryCode;
+             var Res: TCountryInfo; var ActualSize: cardinal): cardinal; cdecl;
+external 'NLS' index 5;

rtl/os2/system.pas

@@ -200,6 +200,9 @@ type
   TUniFreeLocaleObject = function (Locale_Object: TLocaleObject): longint;
                                                                          cdecl;
 
+  TUniMapCtryToLocale = function (CountryCode: cardinal; LocaleName: PWideChar;
+                                             BufSize: longint): longint; cdecl;
+
 
 const
   DosCallsHandle: THandle = THandle (-1);
@@ -224,6 +227,7 @@ var
   Sys_UniStrColl: TUniStrColl;
   Sys_UniCreateLocaleObject: TUniCreateLocaleObject;
   Sys_UniFreeLocaleObject: TUniFreeLocaleObject;
+  Sys_UniMapCtryToLocale: TUniMapCtryToLocale;
 
 {$ENDIF OS2UNICODE}
 

rtl/os2/sysucode.inc

@@ -187,7 +187,7 @@ const
   EmptyCC: TCountryCode = (Country: 0; Codepage: 0); (* Empty = current *)
   (* 819 = IBM codepage number for ISO 8859-1 used in FPC default *)
   (* dummy translation between UnicodeString and AnsiString.      *)
-  IsoCC: TCountryCode = (Country: 1; Codepage: 819); (* Empty = current *)
+  IsoCC: TCountryCode = (Country: 1; Codepage: 819); (* US with ISO 8859-1 *)
   (* The following two arrays are initialized on startup in case that *)
   (* Dummy* routines must be used. First for current codepage...      *)
   DBCSLeadRangesEnd: byte = 0;
@@ -448,7 +448,7 @@ begin
     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?! }
+    DummyUniUConvToUcs := Uls_BufferFull; { According to IBM documentation Uls_Invalid and not Uls_BufferFull is returned by UniUConvFromUcs?! }
    end
   else
    begin
@@ -462,6 +462,19 @@ begin
 end;
 
 
+function DummyUniMapCtryToLocale (CountryCode: cardinal; LocaleName: PWideChar;
+                                             BufSize: longint): longint; cdecl;
+begin
+  if BufSize = 0 then
+   DummyUniMapCtryToLocale := Uls_Invalid
+  else
+   begin
+    LocaleName^ := #0;
+    DummyUniMapCtryToLocale := Uls_Unsupported;
+   end;
+end;
+
+
 procedure InitDBCSLeadRanges;
 var
   RC: cardinal;
@@ -703,6 +716,8 @@ var
   RC: cardinal;
   CPArr: TCPArray;
   ReturnedSize: cardinal;
+  WA: array [0..9] of WideChar; (* Even just 6 WideChars should be enough *)
+  CI: TCountryInfo;
 begin
   if InInitDefaultCP <> -1 then
    begin
@@ -751,13 +766,39 @@ begin
      OSErrorWatch (cardinal (RCI));
     DefLocObj := nil;
    end;
+  if UniAPI then (* Do not bother with the locale object otherwise *)
+   begin
     RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WNull, DefLocObj);
     if RCI <> 0 then
      begin
       OSErrorWatch (cardinal (RCI));
+      DefLocObj := nil;
 (* The locale dependent routines like comparison require a valid locale *)
 (* setting, but the locale set using environment variable LANG is not *)
-(* recognized by OS/2 -> we try the "Universal" locale as a fallback. *)
+(* recognized by OS/2 -> let's try to derive the locale from country *)
+      RC := DosQueryCtryInfo (SizeOf (CI), EmptyCC, CI, ReturnedSize);
+      if RC = 0 then
+       begin
+        RCI := Sys_UniMapCtryToLocale (CI.Country, @WA [0],
+                                            SizeOf (WA) div SizeOf (WideChar));
+        if RCI = 0 then
+         begin
+          RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WA [0],
+                                                                    DefLocObj);
+          if RCI <> 0 then
+           begin
+            OSErrorWatch (cardinal (RCI));
+            DefLocObj := nil;
+           end;
+         end
+        else
+         OSErrorWatch (cardinal (RCI));
+       end
+      else
+       OSErrorWatch (RC);
+      if DefLocObj = nil then
+(* Still no success -> let's use the "Universal" locale as a fallback. *)
+       begin
         RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WUniv [0],
                                                                     DefLocObj);
         if RCI <> 0 then
@@ -766,7 +807,9 @@ begin
           DefLocObj := nil;
          end;
        end;
-  if not (UniAPI) then
+     end;
+   end
+  else (* not UniAPI *)
    ReInitDummyAnsiSupport;
   InInitDefaultCP := -1;
 end;
@@ -1603,6 +1646,11 @@ begin
                         if RC = 0 then
                          begin
                           Sys_UniFreeLocaleObject := TUniFreeLocaleObject (P);
+                          RC := DosQueryProcAddr (LibUniHandle,
+                                                OrdUniMapCtryToLocale, nil, P);
+                          if RC = 0 then
+                           begin
+                            Sys_UniMapCtryToLocale := TUniMapCtryToLocale (P);
 
                             UniAPI := true;
                            end;
@@ -1617,6 +1665,7 @@ begin
          end;
        end;
      end;
+   end;
   if RC <> 0 then
    OSErrorWatch (RC);
   if not (UniAPI) then
@@ -1631,6 +1680,7 @@ begin
     Sys_UniStrColl := @DummyUniStrColl;
     Sys_UniCreateLocaleObject := @DummyUniCreateLocaleObject;
     Sys_UniFreeLocaleObject := @DummyUniFreeLocaleObject;
+    Sys_UniMapCtryToLocale := @DummyUniMapCtryToLocale;
     InitDummyAnsiSupport;
    end;