[Back to DOS SWAG index] [Back to Main SWAG index] [Original]

    {
      Borland Pascal 7.0 National Language Support, with support for protected
      mode. Written in october 1993 by Helge Olav Helgesen

      The purpose of this unit is to give you the ability to write country-
      dependant programs. I won't explain much how it works; since you have the
      source, feel free to explore/change the source.

      To do so I have a written a colletion of procedures, which are described
      here:

      procedure CreateTable(cc: Word);
        This one creates a new table with the specified country-code. if you
        specify a value of 0, the default country will be loaded. You should
        check for errors thru GetError and PeekError.
      procedure DumpTable  (const name: string);
        This one was written for debugging only, and shoudn't be used. It saves
        the current translation table to the specific file
      procedure Upper(var s: OpenString);
      procedure Lower(var s: OpenString);
        These two translates a string into upper or lower case only.
      function GetError:  word;
      function PeekError: word;
        These two can be used to get (and clear) the result from last
        CreateTable. GetError clears ErrorCode afterwards, while PeekError
        doesn't.
      function Convert2Time(const dt: DateTime): string8;
        This one will create a formatted string containing the time specified
        in DateTime.Hour, DateTime.Min and DateTime.Sec. The string is formatted
        according to the loaded country.
      function Convert2Date(const dt: DateTime): string8;
        This one does the same as the one above, except that a date is returned
        instead.
      function ConvertR2Currency(no: real): string;
        This one will turn a real value into a formatted string, with the county's
        currency symbol placed right.
        The line 'WriteLn(ConvertR2Currency(1234.123));' will result
        In USA:    $1,234.12
        In Norway: Kr 1.234,12
      function UpChar(Ch: Char): Char;
      function LoChar(Ch: Char): Char;
        These two are written with inline statements, and will thus place the
        expanded code into your program's code segment. Since they became
        fairly large, you shoudn't use them too much.
      procedure DumpAllCountries;
        This one is only compiled in real mode, and is only intended to use with
        debugging. It writes all countries that is available to the screen.
      var Table: TTranslationTable;
        This is *the* 256 byte translation table, which contains the mapping to
        upper and lower chars.
      var ErrorCode: word;
        Result from last CreateTable. This is the Dos error code, as described
        in 'Run-time error messages'.
      var CurrTable: word;
        If last CreateTable successed, this contains the country that is loaded.
      var UnitOK: boolean;
        Is TRUE if
          1) Dos 3+ is loaded
          2) Could allocate real-mode memory (DPMI only)
      var CountryInfo: PCountryInfo;
        This is a pointer to the current countrys info table. This pointer should
        never derefenced unless UnitOK is true. It contains only valid data if
      (CurrTable>0) and UnitOK!

      I haven't done much to optimize the code. So even small changes may
      increase the speed. If you have any comments, suggestion etc. feel free
      to leave me a note.

      You can reach me thru the following nets:
        ILink     - thru Qmail, Programming, ASM and Pascal
        PolarNet  - thru Pascal and Post
        Rime      - thru Common, Pascal and ASM. I'm located at site MIDNIGHT
        ScanNet   - virtually any conference
        SourceNet - thru the Pascal conference
        WEB       - thru the Pascal conference

      You may also reach me at the following bulletin boards:
        Group One BBS       - +1 312 752-1258
        Midnight Sun BBS    - +47 755 84 545
        Programmer's BBS    - +47 22 71 41 07

      In all cases, my name is HELGE HELGESEN. My mail address is:
      Helge Olav Helgesen
      Box 726
      8001 BODOE
      Norway

      Tlf. +47 755 23 694
    }
    {$S-,B- Do not change these! A change will cause faults! }
    {$G+,D+,R-,Q-,L+,O+}
    {$IFDEF Windows}Sorry, Windows is not supported...{$ENDIF}

    unit NLS;

    interface

    uses {$IFDEF DPMI}WinAPI,{$ENDIF}Dos;

    type
      TTranslationTable = array[0..1, 0..127] of char;
      AChar = record { ASCIIZ char from Country Info }
        Letter: char;
        Dummy: byte;
      end; { AChar }
      PCountryInfo = ^TCountryInfo;
      TCountryInfo = record
        DTFormat: word;                { Date/Time format     }
        CurrSym:  array[0..4] of char; { currency symbol      }
        ThouSep,                       { thousand separator   }
        DeciSep,                       { decimal separator    }
        DateSep,                       { date separator       }
        TimeSep:  AChar;               { time separator       }
        CurrFmt:  byte;                { currency format      }
        Digits:   byte;                { digits after decimal }
        TimeFmt:  boolean;             { FALSE=12h else 24h   }
        CaseMap:  pointer;             { real mode case map   }
        DataSep:  AChar;               { data list separator  }
        RFU:      array[0..9] of byte; { not used             }
      end; { TCountryInfo }
      String8 = string[12];

    var
      Table: TTranslationTable;  { the translation table                   }
      ErrorCode: word;           { error code from last create table       }
      CurrTable: word;           { current country loaded, or 0 if none    }
      UnitOK: boolean;           { true if extentions are allowed          }
      CountryInfo: PCountryInfo; { NB! Protected Mode selector under DPMI! }

    procedure CreateTable(cp: word);
      { -creates new table }
    procedure DumpTable  (const name: string);
      { -saves table to disk, mainly written for debugging purposes }
    procedure Upper      (var s: OpenString);
      { -translate string to upper case (A NAME) }
    procedure Lower      (var s: OpenString);
      { -translate string to lower case (a name) }
    function  GetError:  word;
      { -get and clear error }
    function  PeekError: word;
      { -get error }
    function  Convert2Time(const dt: DateTime): string8;
      { -converts time part of DateTime rec info country dep. string }
    function  Convert2Date(const dt: DateTime): string8;
      { -converts date part into XX:YY:ZZ country dep. }
    function  ConvertR2Currency(no: real): string;
      { -converts real value to currency }
    function  UpChar(Ch: Char): Char;
      { -converts char to upper case }
    inline($58/        { pop ax }
           $88/$c4/    { mov ah, al }
           $a8/$80/    { test al, 80h }
           $74/$10/    { je @1 }
           $8b/$d8/    { mov bx, ax }
           $32/$ff/    { xor bh, bh }
           $8a/$a7/    { mov ah, [bx+ }
           >Table-$80/ { Table-80h] }
           $84/$e4/    { test ah, ah }
           $74/$0d/    { le @2 }
           $88/$e0/    { mov al, ah }
           $eb/$09/    { jmp @2 }
    {@1:}  $f6/$d4/    { not ah }
           $f6/$c4/$60/{ test ah, 60h }
           $75/$02/    { jne @2 }
           $34/$20     { xor al, 20h }
    {@2:} );
    function  LoChar(Ch: Char): Char;
      { -translates Ch to lower char }
    inline($58/        { pop ax }
           $a8/$80/    { test al, 80h }
           $74/$10/    { le @1 }
           $8b/$d8/    { mov bx, ax }
           $32/$ff/    { xor bh, bh }
           $8a/$a7/    { mov ah, [bx+ }
           >Table/     { TABLE] }
           $0a/$e4/    { or ah, ah }
           $74/$0c/    { je @2 }
           $88/$e0/    { mov al, ah }
           $eb/$08/    { jmp @2 }
    {@1:}  $88/$c4/    { mov ah, al }
           $a8/$c0/    { test al, 0c0h }
           $74/$08/    { je @2 }
           $34/$20     { xor al, 20h }
    {@2:} );

    {$IFDEF MSDOS}
    procedure DumpAllCountries;
      { -dumps all country codes supported. For debugging. Works only in real mode }
    {$ENDIF}

    implementation

    {$IFDEF DPMI}
    type
      TBit32 = record
        Low, High: word;
      end; { Bit32 }
      TCallRealMode = record { DPMI structure used to call real mode procs }
        EDI,   ESI, EBP, RFU1, EBX,
        EDX,   ECX, EAX: TBit32;
        Flags, rES, rDS, rFS,
        rGS,   rIP, rCS, rSP,
        rSS:   word;
      end; { TCallRealMode }

    var
      ciSelector: TBit32;  { selector and segment to CountryInfo     }
      MyExitProc: pointer; { DPMI exit proc to deallocate Dos memory }
    {$ENDIF}

    type
      string2 = string[2];
      Pstring = ^String;

    function Convert2Digit(no: word): string2;
    var
      s: string8;
    begin
      Str(no:2, s);
      if s[0]>#2 then delete(s, 1, byte(s[0])-2);
      if s[1]=#32 then s[1]:='0';
      Convert2Digit:=s;
    end; { Convert2Digit }

    {$IFDEF MSDOS}
    procedure DumpAllCountries;
      function TestCountry(no: word): boolean; assembler;
      var dummy: TCountryInfo;
      asm
        push ds
        mov  ax, ss
        mov  ds, ax
        lea  dx, dummy
        mov  ax, $38ff
        mov  bx, no
        or   bh, bh
        je   @1
        mov  al, bl
    @1: int  $21
        pop  ds
        jc   @x
        xor  ax, ax
    @x:
      end; { DumpAllcountries.TestCountry }
    var
      x: word;
    begin
      for x:=0 to 900 do if not TestCountry(x) then write(x:10);
    end; { DumpAllCountries }
    {$ENDIF}

    function Convert2Time;
    const
      AM: string2 = 'AM';
      PM: string2 = 'PM';
      function To12(no: word): word;
      begin
        if no>12 then To12:=no-12 else To12:=no;
      end; { Convert2Time.To12 }
      function AmPm(no: word): Pstring;
      begin
        if no>12 then AmPm:=@PM else AmPm:=@AM;
      end; { Convert2Time.AmPm }
    var
      Delemiter: char;
    begin { Convert2Time }
      if UnitOK and (ErrorCode=0) then
        Delemiter:=CountryInfo^.TimeSep.Letter
      else
        Delemiter:=':';
      if UnitOK and (CurrTable>0) and CountryInfo^.TimeFmt then
        Convert2Time:=Convert2Digit(dt.Hour)+Delemiter+ { time }
                      Convert2Digit(dt.Min)+Delemiter+  { min  }
                      Convert2Digit(dt.Sec)
      else
        Convert2Time:=Convert2Digit(To12(dt.Hour))+Delemiter+ { time }
                      Convert2Digit(dt.Min)+Delemiter+        { min  }
                      Convert2Digit(dt.Sec)+#32+AMPM(dt.Hour)^{ sec  }
    end; { Convert2Time }

    function Convert2Date;
    var
      Dele: char;
    begin
      if UnitOK and (CurrTable>0) then
        Dele:=CountryInfo^.DateSep.Letter
      else
        Dele:='/';
      if UnitOK and (CurrTable>0) and (CountryInfo^.DTFormat>0) then
      case CountryInfo^.DTFormat of
        1: Convert2Date:=Convert2Digit(dt.Day)+Dele+   { date  }
                         Convert2Digit(dt.Month)+Dele+ { month }
                         Convert2Digit(dt.Year);       { year  }
        2: Convert2Date:=Convert2Digit(dt.Year)+Dele+  { year  }
                         Convert2Digit(dt.Month)+Dele+ { month }
                         Convert2Digit(dt.Day);
      end { case }
      else { if }
        Convert2Date:=   Convert2Digit(dt.Month)+Dele+ { month }
                         Convert2Digit(dt.Day)+Dele+   { day   }
                         Convert2Digit(dt.Year);       { year  }
    end; { Convert2Time }

    function ConvertR2Currency;
      function GetCurrency: string8;
      var
        s: string8;
      begin
        s:=CountryInfo^.CurrSym;
        while s[byte(s[0])]=#0 do dec(s[0]);
        GetCurrency:=s;
      end; { ConvertR2Currency.GetCurrency }
      function FormatString(s: string): string;
      var
        Comma, Digits: byte;
        c: integer;
        Dele: char;
      begin
        Dele:=CountryInfo^.ThouSep.Letter;     { get thousand delemiter          }
        Digits:=Pos('.', s);                   { digits before delemither        }
        Comma:=Digits;                         { save comma position             }
        if Digits=0 then Digits:=Length(s)+1;  { start rightmost if no comma     }
        c:=Digits-3;                           { init counter                    }
        while c>2 do
        begin
          Insert(Dele, s, c);                  { insert thousand delemither      }
          Dec(c, 3);                           { adjust pointer                  }
          if Comma>0 then Inc(Comma);          { increase comma position(if any) }
        end; { while }
        if Comma>0 then                        { adjust comma, if any            }
          s[Comma]:=CountryInfo^.DeciSep.Letter;
        FormatString:=s;
      end; { ConvertR2Currency.FormatString }
      function PlaceCurrency(s: string): string;
      var
        x: byte;
      begin
        x:=Pos(CountryInfo^.DeciSep.Letter, s);
        Delete(s, x, 1);
        Insert(GetCurrency, s, x);
        PlaceCurrency:=s;
      end; { ConvertR2Currency.PlaceCurrency }
    var
      s: string[20];
    begin { ConvertR2Currency }
      if UnitOK and (CurrTable>0) then
      begin
        Str(no:20:CountryInfo^.Digits, s);
        while s[1]=#32 do delete(s, 1, 1);
        s:=FormatString(s);
      end
      else
      begin
        Str(no:20:2, s);
        while s[1]=#32 do delete(s, 1, 1);
      end; { if/else }
      if UnitOK and (CurrTable>0) then
      case CountryInfo^.CurrFmt of
        0: s:=GetCurrency+s;
        1: s:=s+GetCurrency;
        2: s:=GetCurrency+#32+s;
        3: s:=s+#32+GetCurrency;
        4: s:=PlaceCurrency(s);
      end; { case }
      ConvertR2Currency:=s;
    end; { ConvertR2Currency }

    procedure DumpTable;
    var
      f: file of TTranslationTable;
    begin
      assign(f, name);
      rewrite(f);
      write(f, Table);
      close(f);
    end;

    procedure CreateTable;
    var
      b: byte;
      c, d: char;
      procedure GetCountryInfo(cp: word);
      var
        r: Registers;
      begin
        r.AX:=$38FF;
        if cp>255 then r.BX:=cp else r.AL:=Lo(cp);
        r.DS:=Seg(CountryInfo^);
        r.DX:=Ofs(CountryInfo^);
        MsDos(r);
        if r.Flags and 1=1 then ErrorCode:=r.AX;
        if ErrorCode=0 then CurrTable:=r.BX else CurrTable:=0;
      end; { CreateTable.GetCoutryInfo }
      function CallCaseMap(Letter: char): char; assembler;
    {$IFNDEF MSDOS}
      var
        regs: TCallRealMode;
    {$ENDIF}
      asm
        mov  al, Letter
      {$IFNDEF MSDOS}
        mov  word ptr regs.EAX, ax
        mov  regs.rSP, 0
        mov  regs.rSS, 0
        les  di, CountryInfo
        mov  ax, word ptr es:[di].TCountryInfo.CaseMap
        mov  regs.RIP, ax
        mov  ax, word ptr es:[di].TCountryInfo.CaseMap+2
        mov  regs.RCS, ax
        mov  ax, ss
        mov  es, ax
        lea  di, regs
        xor  cx, cx
        mov  ax, $301
        int  $31 { execute real mode proc }
        mov  ax, word ptr regs.EAX
      {$ELSE}
        les  di, CountryInfo
        call es:[di].TCountryInfo.CaseMap
      {$ENDIF}
      end; { CreateTable.CallCaseMap }
      procedure MapIn(NewChar, OldChar: char);
      begin
        Table[0, byte(OldChar) and $7f]:=NewChar;
        Table[1, byte(NewChar) and $7f]:=OldChar;
      end; { CreateTable.MapIn }
    begin { CreateTable }
      if (ErrorCode>0) or not UnitOK then exit; { leave if any pending error }
      FillChar(Table, sizeof(Table), 0);
      GetCountryInfo(cp);
      if ErrorCode>0 then exit; { leave if any error occured }
      for b:=0 to 127 do
      begin
        c:=CallCaseMap(char(b+128));
        if c<>char(b+128) then MapIn(c, char(b+128));
      end; { for }
    end; { CreateTable }

    procedure UpCase; assembler;
    {
      This translates the incoming char in AL into upper case if it is defined
      in the translation table.
      Please note that if you enable stack checking, this proc won't work...
    }
    asm
      test al, $80
      je   @1
      xor  ah, ah
      mov  bx, ax
      mov  ah, byte[Table+bx-$80]
      test ah, ah
      je   @x
      mov  al, ah
      jmp  @x
    @1:
      cmp  al, 'z'
      jg   @x
      cmp  al, 'a'
      jl   @x
      xor  al, $20
    @x:
    end; { UpChar }

    procedure LowChar; assembler;
    asm
      test al, $80
      je   @1
      mov  bx, ax
      xor  bh, bh
      mov  ah, byte[Table+bx]
      or   ah, ah
      je   @x
      mov  al, ah
      jmp  @x
    @1:
      cmp  al, 'Z'
      jg   @x
      cmp  al, 'A'
      jl   @x
      xor  al, $20
    @x:
    end; { LowChar }

    procedure Upper; assembler;
    asm
      les  di, s
      mov  cl, es:[di]
      xor  ch, ch
      jcxz @x
      inc  di
    @1:
      mov  al, es:[di]
      call UpCase
      mov  es:[di], al
      inc  di
      loop @1
    @x:
    end; { Upper }

    procedure Lower; assembler;
    asm
      les  di, s
      mov  cl, es:[di]
      xor  ch, ch
      jcxz @x
      inc  di
    @1:
      mov  al, es:[di]
      call LowChar
      mov  es:[di], al
      inc  di
      loop @1
    @x:
    end; { Lower }

    function GetError; assembler;
    asm
      mov  ax, ErrorCode
      mov  ErrorCode, 0
    end; { GetError }

    function PeekError; assembler;
    asm
      mov  ax, ErrorCode
    end; { PeekError }

    {$IFNDEF MSDOS}
    procedure Leave; far;
    begin
      ExitProc:=MyExitProc;           { change to old handler }
      GlobalDosFree(ciSelector.High); { release Dos memory    }
    end; { Leave }

    procedure InitExitProc;
    begin
      MyExitProc:=ExitProc; { save old handler }
      ExitProc:=@Leave; { save my own handler  }
    end; { InitExitProc }
    {$ENDIF}

    begin { NLS }
      UnitOk:=Lo(DosVersion)>=3; { does only work for Dos 3+ }
      if UnitOK then { allocate memory }
      begin
      {$IFDEF DPMI}
        longint(ciSelector):=GlobalDosAlloc(sizeof(TCountryInfo));
        if ciSelector.Low=0 then UnitOK:=False; { if not enough Dos memory }
        CountryInfo:=Ptr(ciSelector.Low, 0); { make protected mode pointer }
        if UnitOK then InitExitProc; { change exit proc                    }
      {$ELSE}
        if MaxAvail>sizeof(CountryInfo^) then{ allocate if enough memory   }
          New(CountryInfo)
        else
          UnitOK:=False; { or disable extentions }
      {$ENDIF}
      end; { if UnitOK }
    end.

[Back to DOS SWAG index] [Back to Main SWAG index] [Original]