POINT Software Programming/PPROG1.ISO/pascal/swag/dos.swg/0039_National Language Support.pas

Pascal/Delphi Source File | 1993-11-21 | 16.5 KB | 559 lines

{
  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       - [phone]
    Midnight Sun BBS    - [phone]
    Programmer's BBS    - [phone]

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

  Tlf. [phone]
}
{$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.