+ Added internationalization support and more format functions

rtl/objpas/datih.inc

@@ -27,20 +27,7 @@ const
    MSecsPerDay = SecsPerDay * 1000;
 
    DateDelta = 693594;        // Days between 1/1/0001 and 12/31/1899
-   DateSeparator: char = '-';
-   TimeSeparator: char = ':';
-   TimeAMString: string = 'am';
-   TimePMString: string = 'pm';
-   ShortMonthNames: array[1..12] of string =
-     ('Jan','Feb','Mar','Apr','May','Jun',
-      'Jul','Aug','Sep','Oct','Nov','Dec');
-   LongMonthNames: array[1..12] of string =
-     ('January','February','March','April','May','June',
-      'July','August','September','October','November','December');
-   ShortDayNames: array[1..7] of string =
-     ('Sun','Mon','Tue','Wen','Thu','Fri','Sat');
-   LongDayNames: array[1..7] of string =
-     ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
+
 
    {  date time formatting characters:
       c      : shortdateformat + ' ' + shorttimeformat
@@ -73,10 +60,6 @@ const
       'xx'   : literal text
    }
 
-   ShortDateFormat: string = 'd/m/y';
-   LongDateFormat: string = 'dd" "mmmm" "yyyy';
-   ShortTimeFormat: string = 'hh:nn';
-   LongTimeFormat: string = 'hh:nn:ss';
 
    Eoln = #10;
 
@@ -123,7 +106,10 @@ Function FileDateToDateTime (Filedate : Longint) : TDateTime;
 {
 
   $Log$
-  Revision 1.4  1998-10-11 13:40:53  michael
+  Revision 1.5  1999-02-28 13:17:34  michael
+  + Added internationalization support and more format functions
+
+  Revision 1.4  1998/10/11 13:40:53  michael
   + Added Conversion TDateTime <-> file date and time
 
   Revision 1.3  1998/10/08 14:07:45  florian

rtl/objpas/sysinth.inc

@@ -0,0 +1,130 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 by the Free Pascal development team
+
+    International settings for Sysutils unit.
+    
+    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.
+
+ **********************************************************************}
+
+{
+  All the variables presented here must be set by the InitInternational
+  routine. They must be set to match the 'local' settings, although 
+  most have an initial value.
+  
+  
+  These routines are OS-dependent.
+}
+
+{ ---------------------------------------------------------------------
+    Upper/lowercase translations 
+  ---------------------------------------------------------------------}
+
+type
+   TCaseTranslationTable = array[0..255] of char;
+
+var
+   { Tables with upper and lowercase forms of character sets. 
+     MUST be initialized with the correct code-pages }
+   UpperCaseTable: TCaseTranslationTable;
+   LowerCaseTable: TCaseTranslationTable;
+  
+{ ---------------------------------------------------------------------
+    Date formatting settings
+  ---------------------------------------------------------------------}
+
+Const 
+
+   { Character to be put between date, month and year }
+   DateSeparator: char = '-';
+
+   { Format used for short date notation }
+   ShortDateFormat: string = 'd/m/y';
+   
+   { Format used for long date notation }
+   LongDateFormat: string = 'dd" "mmmm" "yyyy';
+   
+   
+   { Short names of months. }
+   ShortMonthNames: array[1..12] of string =
+     ('Jan','Feb','Mar','Apr','May','Jun',
+      'Jul','Aug','Sep','Oct','Nov','Dec');
+      
+   { Long names of months. }   
+   LongMonthNames: array[1..12] of string =
+     ('January','February','March','April','May','June',
+      'July','August','September','October','November','December');
+   
+   { Short names of days }   
+   ShortDayNames: array[1..7] of string =
+     ('Sun','Mon','Tue','Wen','Thu','Fri','Sat');
+     
+   { Full names of days }  
+   LongDayNames: array[1..7] of string =
+     ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
+  
+   { Format used for short time notation }
+   ShortTimeFormat: string = 'hh:nn';
+   
+   { Format used for long time notation }
+   LongTimeFormat: string = 'hh:nn:ss';
+   
+   { Character to be put between hours and minutes }
+   TimeSeparator: char = ':';
+   
+   { String to indicate AM time when using 12 hour clock. }
+   TimeAMString: string[7] = 'AM';
+
+   { String to indicate PM time when using 12 hour clock. }
+   TimePMString: string[7] = 'PM';
+
+
+
+{ ---------------------------------------------------------------------
+    Number formatting constants
+  ---------------------------------------------------------------------}
+  
+
+  { Character that comes between integer and fractional part of a number }
+  DecimalSeparator : Char = '.';
+  
+  { Character that is put every 3 numbers in a currency }
+  ThousandSeparator : Char = ',';
+  
+  { Number of decimals to use when formatting a currency.  }
+  CurrencyDecimals : Byte = 2;
+  
+  { Format to use when formatting currency :
+    0 = $1 
+    1 = 1$ 
+    2 = $ 1
+    3 = 1 $
+    4 = Currency string replaces decimal indicator. e.g. 1$50 
+   }
+  CurrencyFormat : Byte = 1;
+
+  { Same as above, only for negative currencies:
+    0 = ($1)
+    1 = -$1
+    2 = $-1
+    3 = $1-
+    4 = (1$)
+    5 = -1$
+    6 = 1-$
+    7 = 1$-
+    8 = -1 $
+    9 = -$ 1
+    10 = $ 1-
+   }
+  NegCurrFormat : Byte = 5;
+  
+  { Currency notation. Default is $ for dollars. }
+  CurrencyString : String[7] = '$';
+

rtl/objpas/sysstr.inc

@@ -163,12 +163,6 @@ end ;
 {   these functions rely on the character set loaded by the OS                 }
 {==============================================================================}
 
-type
-   TCaseTranslationTable = array[0..255] of char;
-
-var
-   UpperCaseTable: TCaseTranslationTable;
-   LowerCaseTable: TCaseTranslationTable;
 
 function AnsiUpperCase(const s: string): string;
 var len, i: integer;
@@ -698,23 +692,196 @@ begin
     end;
 end;
 
+Function FormatBuf (Var Buffer; BufLen : Cardinal; 
+                     Const Fmt; fmtLen : Cardinal; 
+                     Const Args : Array of const) : Cardinal;
+
+Var S,F : String;
+
+begin
+  Setlength(F,fmtlen);
+  Move(fmt,F[1],fmtlen);
+  S:=Format (F,Args);
+  If Length(S)>Buflen then
+    Result:=Length(S)
+  else
+    Result:=Buflen;
+  Move(S[1],Buffer,Result);
+end;                     
+
+Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const);
+
+begin
+  Res:=Format(fmt,Args);
+end;
+
+Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar;
+
+begin
+  Buffer[FormatBuf(Buffer^,Maxint,Fmt^,strlen(fmt),args)]:=#0;
+  Result:=Buffer;
+end;
+
+Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar;
+
+begin
+  Buffer[FormatBuf(Buffer^,MaxLen,Fmt^,strlen(fmt),args)]:=#0;
+  Result:=Buffer;
+end;
+
+Function FloatToStr(Value: Extended): String;
+Begin
+  Result := FloatToStrF(Value, ffGeneral, 15, 0);
+End;
+
+Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
+Var
+  P: Integer;
+  Negative, TooSmall, TooLarge: Boolean;
+Begin
+  Case format Of
+
+    ffGeneral:
+
+      Begin
+        If (Precision = -1) Or (Precision > 15) Then Precision := 15;
+        TooSmall := Abs(Value) < 0.00001;
+        If Not TooSmall Then
+        Begin
+          Str(Value:0:999, Result);
+          P := Pos('.', Result);
+          Result[P] := DecimalSeparator;
+          TooLarge := P > Precision + 1;
+        End;
+
+        If TooSmall Or TooLarge Then
+          Result := FloatToStrF(Value, ffExponent, Precision, Digits);
+
+        P := Length(Result);
+        While Result[P] = '0' Do Dec(P);
+        If Result[P] = DecimalSeparator Then Dec(P);
+        SetLength(Result, P);
+      End;
+
+    ffExponent:
+
+      Begin
+        If (Precision = -1) Or (Precision > 15) Then Precision := 15;
+        Str(Value:Precision + 8, Result);
+        Result[3] := DecimalSeparator;
+        If (Digits < 4) And (Result[Precision + 5] = '0') Then
+        Begin
+          Delete(Result, Precision + 5, 1);
+          If (Digits < 3) And (Result[Precision + 5] = '0') Then
+          Begin
+            Delete(Result, Precision + 5, 1);
+            If (Digits < 2) And (Result[Precision + 5] = '0') Then
+            Begin
+              Delete(Result, Precision + 5, 1);
+              If (Digits < 1) And (Result[Precision + 5] = '0') Then Delete(Result, Precision + 3, 3);
+            End;
+          End;
+        End;
+        If Result[1] = ' ' Then Delete(Result, 1, 1);
+      End;
+
+    ffFixed:
+
+      Begin
+        If Digits = -1 Then Digits := 2
+        Else If Digits > 15 Then Digits := 15;
+        Str(Value:0:Digits, Result);
+        If Result[1] = ' ' Then Delete(Result, 1, 1);
+        P := Pos('.', Result);
+        If P <> 0 Then Result[P] := DecimalSeparator;
+      End;
+
+    ffNumber:
+
+      Begin
+        If Digits = -1 Then Digits := 2
+        Else If Digits > 15 Then Digits := 15;
+        Str(Value:0:Digits, Result);
+        If Result[1] = ' ' Then Delete(Result, 1, 1);
+        P := Pos('.', Result);
+        If P <> 0 Then Result[P] := DecimalSeparator;
+        Dec(P, 3);
+        While (P > 1) Do
+        Begin
+          If Result[P - 1] <> '-' Then Insert(ThousandSeparator, Result, P);
+          Dec(P, 3);
+        End;
+      End;
+
+    ffCurrency:
+
+      Begin
+        If Value < 0 Then
+        Begin
+          Negative := True;
+          Value := -Value;
+        End
+        Else Negative := False;
+
+        If Digits = -1 Then Digits := CurrencyDecimals
+        Else If Digits > 15 Then Digits := 15;
+        Str(Value:0:Digits, Result);
+        If Result[1] = ' ' Then Delete(Result, 1, 1);
+        P := Pos('.', Result);
+        If P <> 0 Then Result[P] := DecimalSeparator;
+        Dec(P, 3);
+        While (P > 1) Do
+        Begin
+          Insert(ThousandSeparator, Result, P);
+          Dec(P, 3);
+        End;
+
+        If Not Negative Then
+        Begin
+          Case CurrencyFormat Of
+            0: Result := CurrencyString + Result;
+            1: Result := Result + CurrencyString;
+            2: Result := CurrencyString + ' ' + Result;
+            3: Result := Result + ' ' + CurrencyString;
+          End
+        End
+        Else
+        Begin
+          Case NegCurrFormat Of
+            0: Result := '(' + CurrencyString + Result + ')';
+            1: Result := '-' + CurrencyString + Result;
+            2: Result := CurrencyString + '-' + Result;
+            3: Result := CurrencyString + Result + '-';
+            4: Result := '(' + Result + CurrencyString + ')';
+            5: Result := '-' + Result + CurrencyString;
+            6: Result := Result + '-' + CurrencyString;
+            7: Result := Result + CurrencyString + '-';
+            8: Result := '-' + Result + ' ' + CurrencyString;
+            9: Result := '-' + CurrencyString + ' ' + Result;
+            10: Result := CurrencyString + ' ' + Result + '-';
+          End;
+        End;
+      End;
+  End;
+End;
+
 {==============================================================================}
 {   extra functions                                                            }
 {==============================================================================}
 
-{   LeftStr returns Count left-most characters from S   }
+{   LeftStr returns Count left-most characters from S }
 
 function LeftStr(const S: string; Count: integer): string;
 begin
-result := Copy(S, 1, Count);
+  result := Copy(S, 1, Count);
 end ;
 
-{    RightStr returns Count right-most characters from S   }
+{ RightStr returns Count right-most characters from S }
 
 function RightStr(const S: string; Count: integer): string;
 begin
-result := Copy(S, 1 + Length(S) - Count, Count);
-end ;
+   result := Copy(S, 1 + Length(S) - Count, Count);
+end;
 
 {    BCDToInt converts the BCD value Value to an integer   }
 
@@ -730,14 +897,16 @@ for i := 0 to SizeOf(Value) shr 1 - 1 do begin
    end ;
 end ;
 
-{  Case Translation Tables  }
-
-   {  Although these tables can be obtained through system calls  }
-   {  it is better to not use those, since most implementation are not 100%  }
-
-   {  WARNING:  }
-   {  before modifying a translation table make sure that the current codepage  }
-   {  of the OS corresponds to the one you make changes to  }
+{
+   Case Translation Tables  
+   Can be used in internationalization support. 
+   
+   Although these tables can be obtained through system calls  
+   it is better to not use those, since most implementation are not 100%  
+   WARNING:  
+   before modifying a translation table make sure that the current codepage  
+   of the OS corresponds to the one you make changes to  
+}
 
 const
    { upper case translation table for character set 850 }
@@ -784,100 +953,12 @@ const
      #240, #241, #242, #243, #244, #245, #246, #247,
      #248, #249, #250, #251, #252, #253, #254, #255 );
 
-{$IFDEF GO32V2}
-
-{  Codepage constants  }
-
-const
-   CP_US = 437;
-   CP_MultiLingual = 850;
-   CP_SlavicLatin2 = 852;
-   CP_Turkish = 857;
-   CP_Portugal = 860;
-   CP_IceLand = 861;
-   CP_Canada = 863;
-   CP_NorwayDenmark = 865;
-
-{  CountryInfo   }
-type
-   TCountryInfo = packed record
-      InfoId: byte;
-      case integer of
-         1: ( Size: word;
-              CountryId: word;
-              CodePage: word;
-              CountryInfo: array[0..33] of byte );
-         2: ( UpperCaseTable: longint );
-         4: ( FilenameUpperCaseTable: longint );
-         5: ( FilecharacterTable: longint );
-         6: ( CollatingTable: longint );
-         7: ( DBCSLeadByteTable: longint );
-   end ;
-
-
-procedure GetExtendedCountryInfo(InfoId: integer; CodePage, CountryId: word; var CountryInfo: TCountryInfo);
-var Regs: Registers;
-begin
-Regs.AH := $65;
-Regs.AL := InfoId;
-Regs.BX := CodePage;
-Regs.DX := CountryId;
-Regs.ES := transfer_buffer div 16;
-Regs.DI := transfer_buffer and 15;
-Regs.CX := SizeOf(TCountryInfo);
-RealIntr($21, Regs);
-DosMemGet(transfer_buffer shr 16, transfer_buffer and 65535, CountryInfo, Regs.CX );
-end ;
-
-procedure InitAnsi;
-var CountryInfo: TCountryInfo; i: integer;
-begin
-{  Fill table entries 0 to 127  }
-for i := 0 to 96 do
-   UpperCaseTable[i] := chr(i);
-for i := 97 to 122 do
-   UpperCaseTable[i] := chr(i - 32);
-for i := 123 to 127 do
-   UpperCaseTable[i] := chr(i);
-for i := 0 to 64 do
-   LowerCaseTable[i] := chr(i);
-for i := 65 to 90 do
-   LowerCaseTable[i] := chr(i + 32);
-for i := 91 to 255 do
-   LowerCaseTable[i] := chr(i);
-{  Get country and codepage info  }
-GetExtendedCountryInfo(1, $FFFF, $FFFF, CountryInfo);
-if CountryInfo.CodePage = 850 then begin
-   Move(CP850UCT, UpperCaseTable[128], 128);
-   Move(CP850LCT, LowerCaseTable[128], 128);
-   end
-else begin
-{ this needs to be checked !!
-  this is correct only if UpperCaseTable is
-  and Offset:Segment word record (PM) }
-   {  get the uppercase table from dosmemory  }
-   GetExtendedCountryInfo(2, $FFFF, $FFFF, CountryInfo);
-   DosMemGet(CountryInfo.UpperCaseTable shr 16, 2 + CountryInfo.UpperCaseTable and 65535, UpperCaseTable[128], 128);
-   for i := 128 to 255 do begin
-      if UpperCaseTable[i] <> chr(i) then
-         LowerCaseTable[ord(UpperCaseTable[i])] := chr(i);
-      end ;
-   end ;
-end ;
-
-{$ELSE}
-// {$IFDEF LINUX}
-
-procedure InitAnsi;
-begin
-end ;
-
-// {$ENDIF}
-{$ENDIF}
-
 {
   $Log$
-  Revision 1.12  1999-02-24 15:56:29  michael
+  Revision 1.13  1999-02-28 13:17:35  michael
+  + Added internationalization support and more format functions
+
+  Revision 1.12  1999/02/24 15:56:29  michael
   + Small fixes. Moved getlocaltime to system-dependent files
 
   Revision 1.11  1999/02/10 22:15:12  michael

rtl/objpas/sysstrh.inc

@@ -27,7 +27,11 @@
 
 type
    PString = ^String;
+   
+   { For FloatToText } 
+   TFloatFormat = (ffGeneral, ffExponent, ffFixed, ffNumber, ffCurrency);
 
+   
 function NewStr(const S: string): PString;
 procedure DisposeStr(S: PString);
 procedure AssignStr(var P: PString; const S: string);
@@ -70,6 +74,12 @@ function StrToIntDef(const S: string; Default: integer): integer;
 function LoadStr(Ident: integer): string;
 // function FmtLoadStr(Ident: integer; const Args: array of const): string;
 Function Format (Const Fmt : String; const Args : Array of const) : String;
+Function FormatBuf (Var Buffer; BufLen : Cardinal; Const Fmt; fmtLen : Cardinal; Const Args : Array of const) : Cardinal;
+Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar;
+Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar;
+Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const);
+Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
+Function FloatToStr(Value: Extended): String;
 
 {==============================================================================}
 {   extra functions                                                            }
@@ -81,7 +91,10 @@ function BCDToInt(Value: integer): integer;
 
 {
   $Log$
-  Revision 1.5  1998-12-15 22:43:11  peter
+  Revision 1.6  1999-02-28 13:17:36  michael
+  + Added internationalization support and more format functions
+
+  Revision 1.5  1998/12/15 22:43:11  peter
     * removed temp symbols
 
   Revision 1.4  1998/11/04 10:20:53  peter

rtl/objpas/sysutils.pp

@@ -18,6 +18,7 @@ interface
 {$MODE objfpc}
 { force ansistrings }
 {$H+}
+
     uses
     {$ifdef linux}
        linux
@@ -26,76 +27,79 @@ interface
        dos,windows
       {$else}
         {$ifdef go32v2}
-       dos,go32
+        dos,go32
         {$endif go32v2}
       {$endif win32}
     {$endif linux}
-       ;
-
-
-    type
-       { some helpful data types }
-
-       tprocedure = procedure;
-
-       tfilename = string;
-
-       longrec = packed record
-          lo,hi : word;
-       end;
-
-       wordrec = packed record
-          lo,hi : byte;
-       end;
-
-       { exceptions }
-       exception = class(TObject)
-        private
-          fmessage : string;
-          fhelpcontext : longint;
-        public
-          constructor create(const msg : string);
-          constructor createfmt(const msg : string; const args : array of const);
-          constructor createres(ident : longint);
-          { !!!! }
-          property helpcontext : longint read fhelpcontext write fhelpcontext;
-          property message : string read fmessage write fmessage;
-       end;
-
-       exceptclass = class of exception;
-
-       { integer math exceptions }
-       EInterror    = Class(Exception);
-       EDivByZero   = Class(EIntError);
-       ERangeError  = Class(EIntError);
-       EIntOverflow = Class(EIntError);
-
-       { General math errors }
-       EMathError  = Class(Exception);
-       EInvalidOp  = Class(EMathError);
-       EZeroDivide = Class(EMathError);
-       EOverflow   = Class(EMathError);
-       EUnderflow  = Class(EMathError);
-
-       { Run-time and I/O Errors }
-       EInOutError = class(Exception)
-         public
-         ErrorCode : Longint;
-         end;
-       EInvalidPointer  = Class(Exception);
-       EOutOfMemory     = Class(Exception);
-       EAccessViolation = Class(Exception);
-       EInvalidCast = Class(Exception);
-
-
-       { String conversion errors }
-       EConvertError = class(Exception);
-
-       { Other errors }
-       EAbort           = Class(Exception);
-       EAbstractError   = Class(Exception);
-       EAssertionFailed = Class(Exception);
+    ;
+
+
+type
+   { some helpful data types }
+
+   tprocedure = procedure;
+
+   tfilename = string;
+
+   longrec = packed record
+      lo,hi : word;
+   end;
+
+   wordrec = packed record
+      lo,hi : byte;
+   end;
+
+   { exceptions }
+   exception = class(TObject)
+    private
+      fmessage : string;
+      fhelpcontext : longint;
+    public
+      constructor create(const msg : string);
+      constructor createfmt(const msg : string; const args : array of const);
+      constructor createres(ident : longint);
+      { !!!! }
+      property helpcontext : longint read fhelpcontext write fhelpcontext;
+      property message : string read fmessage write fmessage;
+   end;
+
+   exceptclass = class of exception;
+
+   { integer math exceptions }
+   EInterror    = Class(Exception);
+   EDivByZero   = Class(EIntError);
+   ERangeError  = Class(EIntError);
+   EIntOverflow = Class(EIntError);
+
+   { General math errors }
+   EMathError  = Class(Exception);
+   EInvalidOp  = Class(EMathError);
+   EZeroDivide = Class(EMathError);
+   EOverflow   = Class(EMathError);
+   EUnderflow  = Class(EMathError);
+
+   { Run-time and I/O Errors }
+   EInOutError = class(Exception)
+     public
+     ErrorCode : Longint;
+     end;
+   EInvalidPointer  = Class(Exception);
+   EOutOfMemory     = Class(Exception);
+   EAccessViolation = Class(Exception);
+   EInvalidCast = Class(Exception);
+
+
+   { String conversion errors }
+   EConvertError = class(Exception);
 
+   { Other errors }
+   EAbort           = Class(Exception);
+   EAbstractError   = Class(Exception);
+   EAssertionFailed = Class(Exception);
+
+  { Read internationalization settings }
+  {$i sysinth.inc}
+ 
   { Read date & Time function declarations }
   {$i datih.inc}
 
@@ -131,6 +135,9 @@ interface
   { Read filename handling functions implementation }
   {$i fina.inc}
 
+  { Read String Handling functions implementation }
+  {$i sysstr.inc}
+
   { Read other file handling function implementations }
   {$i filutil.inc}
 
@@ -140,9 +147,6 @@ interface
   { Read date & Time function implementations }
   {$i dati.inc}
 
-  { Read String Handling functions implementation }
-  {$i sysstr.inc}
-
   { Read pchar handling functions implementation }
   {$i syspch.inc}
 
@@ -266,13 +270,18 @@ begin
 end;
 
 
-{Initialization code.}
+{  Initialization code. }
+
 begin
-  InitExceptions;
+  InitExceptions;       { Initialize exceptions. OS independent }
+  InitInternational;    { Initialize internationalization settings }
 end.
 {
     $Log$
-    Revision 1.22  1999-02-10 22:15:13  michael
+    Revision 1.23  1999-02-28 13:17:37  michael
+    + Added internationalization support and more format functions
+
+    Revision 1.22  1999/02/10 22:15:13  michael
     + Changed to ansistrings
 
     Revision 1.21  1999/02/09 14:24:50  pierre