freepascal.compiler/compiler/cmsgs.pas

{
    $Id$
    Copyright (c) 1998-2000 by Peter Vreman

    This unit implements the message object

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    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.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
unit cmsgs;

{$i fpcdefs.inc}

interface

const
  maxmsgidxparts = 20;

type
  ppchar=^pchar;

  TArrayOfPChar = array[0..1000] of pchar;
  PArrayOfPChar = ^TArrayOfPChar;

  PMessage=^TMessage;
  TMessage=object
    msgfilename : string;
    msgintern   : boolean;
    msgallocsize,
    msgsize,
    msgparts,
    msgs        : longint;
    msgtxt      : pchar;
    msgidx      : array[1..maxmsgidxparts] of PArrayOfPChar;
    msgidxmax   : array[1..maxmsgidxparts] of longint;
    constructor Init(n:longint;const idxmax:array of longint);
    destructor  Done;
    function  LoadIntern(p:pointer;n:longint):boolean;
    function  LoadExtern(const fn:string):boolean;
    procedure ClearIdx;
    procedure CreateIdx;
    function  GetPChar(nr:longint):pchar;
    function  Get(nr:longint):string;
    function  Get4(nr:longint;const s1,s2,s3,s4:string):string;
    function  Get3(nr:longint;const s1,s2,s3:string):string;
    function  Get2(nr:longint;const s1,s2:string):string;
    function  Get1(nr:longint;const s1:string):string;
  end;

{ this will read a line until #10 or #0 and also increase p }
function GetMsgLine(var p:pchar):string;


implementation

uses
  cutils,
  globals,
{$ifdef DELPHI}
  sysutils;
{$else DELPHI}
  strings;
{$endif DELPHI}


    function MsgReplace(const s,s1,s2,s3,s4:string):string;
      var
        last,
        i  : longint;
        hs : string;
      begin
        if s='' then
         begin
           MsgReplace:='';
           exit;
         end;
        hs:='';
        i:=0;
        last:=0;
        while (i<length(s)-1) do
         begin
           inc(i);
           if (s[i]='$') and
              (s[i+1] in ['1'..'4']) then
            begin
              hs:=hs+copy(s,last+1,i-last-1);
              case s[i+1] of
               '1' :
                 hs:=hs+s1;
               '2' :
                 hs:=hs+s2;
               '3' :
                 hs:=hs+s3;
               '4' :
                 hs:=hs+s4;
              end;
              inc(i);
              last:=i;
            end;
         end;
        MsgReplace:=hs+copy(s,last+1,length(s)-last);;
      end;



constructor TMessage.Init(n:longint;const idxmax:array of longint);
var
  i : longint;
begin
  msgtxt:=nil;
  msgsize:=0;
  msgparts:=n;
  if n<>high(idxmax)+1 then
   fail;
  for i:=1to n do
   begin
     msgidxmax[i]:=idxmax[i-1];
     getmem(msgidx[i],msgidxmax[i]*4);
     fillchar(msgidx[i]^,msgidxmax[i]*4,0);
   end;
end;


destructor TMessage.Done;
var
  i : longint;
begin
  for i:=1to msgparts do
   freemem(msgidx[i],msgidxmax[i]*4);
  if msgallocsize>0 then
   begin
     freemem(msgtxt,msgsize);
     msgallocsize:=0;
   end;
  msgtxt:=nil;
  msgsize:=0;
  msgparts:=0;
end;


function TMessage.LoadIntern(p:pointer;n:longint):boolean;
begin
  msgtxt:=pchar(p);
  msgsize:=n;
  msgallocsize:=0;
  msgintern:=true;
  ClearIdx;
  CreateIdx;
  LoadIntern:=true;
end;


function TMessage.LoadExtern(const fn:string):boolean;

{$ifndef FPC}
  procedure readln(var t:text;var s:string);
  var
    c : char;
    i : longint;
  begin
    c:=#0;
    i:=0;
    while (not eof(t)) and (c<>#10) do
     begin
       read(t,c);
       if c<>#10 then
        begin
          inc(i);
          s[i]:=c;
        end;
     end;
    if (i>0) and (s[i]=#13) then
     dec(i);
    s[0]:=chr(i);
  end;
{$endif}

const
  bufsize=8192;
var
  f       : text;
  error,multiline : boolean;
  line,i,j : longint;
  ptxt    : pchar;
  s,s1    : string;
  buf     : pointer;

  procedure err(const msgstr:string);
  begin
    writeln('*** PPC, file ',fn,', error in line ',line,': ',msgstr);
    error:=true;
  end;

begin
  LoadExtern:=false;
  getmem(buf,bufsize);
{Read the message file}
  assign(f,fn);
  {$I-}
   reset(f);
  {$I+}
  if ioresult<>0 then
   begin
     WriteLn('*** PPC, can not open message file ',fn);
     exit;
   end;
  settextbuf(f,buf^,bufsize);
{ First parse the file and count bytes needed }
  error:=false;
  line:=0;
  multiline:=false;
  msgsize:=0;
  while not eof(f) do
   begin
     readln(f,s);
     inc(line);
     if multiline then
      begin
        if s=']' then
         multiline:=false
        else
         inc(msgsize,length(s)+1); { +1 for linebreak }
      end
     else
      begin
        if (s<>'') and not(s[1] in ['#',';','%']) then
         begin
           i:=pos('=',s);
           if i>0 then
            begin
              j:=i+1;
              if not(s[j] in ['0'..'9']) then
               err('no number found')
              else
               begin
                 while (s[j] in ['0'..'9']) do
                  inc(j);
               end;
              if j-i-1<>5 then
               err('number length is not 5');
              if s[j+1]='[' then
               begin
                 inc(msgsize,j-i);
                 multiline:=true
               end
              else
               inc(msgsize,length(s)-i+1);
            end
           else
            err('no = found');
         end;
      end;
   end;
  if multiline then
   err('still in multiline mode');
  if error then
   begin
     freemem(buf,bufsize);
     close(f);
     exit;
   end;
{ now read the buffer in mem }
  msgallocsize:=msgsize;
  getmem(msgtxt,msgallocsize);
  ptxt:=msgtxt;
  reset(f);
  while not eof(f) do
   begin
     readln(f,s);
     if multiline then
      begin
        if s=']' then
         begin
           multiline:=false;
           { overwrite last eol }
           dec(ptxt);
           ptxt^:=#0;
           inc(ptxt);
         end
        else
         begin
           move(s[1],ptxt^,length(s));
           inc(ptxt,length(s));
           ptxt^:=#10;
           inc(ptxt);
         end;
      end
     else
      begin
        if (s<>'') and not(s[1] in ['#',';','%']) then
         begin
           i:=pos('=',s);
           if i>0 then
            begin
              j:=i+1;
              while (s[j] in ['0'..'9']) do
               inc(j);
              { multiline start then no txt }
              if s[j+1]='[' then
               begin
                 s1:=Copy(s,i+1,j-i);
                 move(s1[1],ptxt^,length(s1));
                 inc(ptxt,length(s1));
                 multiline:=true;
               end
              else
               begin
                 { txt including number }
                 s1:=Copy(s,i+1,255);
                 move(s1[1],ptxt^,length(s1));
                 inc(ptxt,length(s1));
                 ptxt^:=#0;
                 inc(ptxt);
               end;
            end;
         end;
      end;
   end;
  close(f);
  freemem(buf,bufsize);
{ now we can create the index, clear if the previous load was also
  an external file, because those can't be reused }
  if not msgintern then
   ClearIdx;
  CreateIdx;
{ set that we've loaded an external file }
  msgintern:=false;
  LoadExtern:=true;
end;


procedure TMessage.ClearIdx;
var
  i : longint;
begin
  { clear }
  for i:=1to msgparts do
   fillchar(msgidx[i]^,msgidxmax[i]*4,0);
end;


procedure TMessage.CreateIdx;
var
  hp1,
  hp,hpend : pchar;
  code : integer;
  num  : longint;
  number : string[5];
  i   : longint;
  numpart,numidx : longint;
begin
  { process msgtxt buffer }
  number:='00000';
  hp:=msgtxt;
  hpend:=@msgtxt[msgsize];
  while (hp<hpend) do
   begin
     hp1:=hp;
     for i:=1to 5 do
      begin
        number[i]:=hp1^;
        inc(hp1);
      end;
     val(number,num,code);
     numpart:=num div 1000;
     numidx:=num mod 1000;
     { check range }
     if (numpart <= msgparts) and (numidx < msgidxmax[numpart]) then
      begin
        { skip _ }
        inc(hp1);
        { put the address in the idx, the numbers are already checked }
        msgidx[numpart]^[numidx]:=hp1;
      end;
     { next string }
     hp:=pchar(@hp[strlen(hp)+1]);
   end;
end;


function GetMsgLine(var p:pchar):string;
var
  i  : longint;
begin
  i:=0;
  while not(p^ in [#0,#10]) and (i<255) do
   begin
     inc(i);
     GetMsgLine[i]:=p^;
     inc(p);
   end;
  { skip #10 }
  if p^=#10 then
   inc(p);
  { if #0 then set p to nil }
  if p^=#0 then
   p:=nil;
  { return string }
  GetMsgLine[0]:=chr(i);
end;


function TMessage.GetPChar(nr:longint):pchar;
begin
  GetPChar:=msgidx[nr div 1000]^[nr mod 1000];
end;


function TMessage.Get(nr:longint):string;
var
  s : string[16];
  hp : pchar;
begin
  hp:=msgidx[nr div 1000]^[nr mod 1000];
  if hp=nil then
   begin
     Str(nr,s);
     Get:='msg nr '+s;
   end
  else
   Get:=StrPas(hp);
end;


function TMessage.Get4(nr:longint;const s1,s2,s3,s4:string):string;
begin
  Get4:=MsgReplace(Get(nr),s1,s2,s3,s4);
end;


function TMessage.Get3(nr:longint;const s1,s2,s3:string):string;
begin
  Get3:=MsgReplace(Get(nr),s1,s2,s3,'');
end;


function TMessage.Get2(nr:longint;const s1,s2:string):string;
begin
  Get2:=MsgReplace(Get(nr),s1,s2,'','');
end;


function TMessage.Get1(nr:longint;const s1:string):string;
begin
  Get1:=MsgReplace(Get(nr),s1,'','','');
end;


end.
{
  $Log$
  Revision 1.5  2002-05-16 19:46:35  carl
  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  + try to fix temp allocation (still in ifdef)
  + generic constructor calls
  + start of tassembler / tmodulebase class cleanup

  Revision 1.3  2002/04/19 15:41:39  peter
    * better replacements that also allow $1 in the replacements without
      replacing that instance also

  Revision 1.2  2002/03/01 12:41:40  peter
    * fixed Message4()

  Revision 1.1  2001/08/20 10:58:48  florian
    * renamed messages unit to cmsgs to avoid conflicts with the
      win32 messages unit

  Revision 1.10  2001/06/03 20:21:08  peter
    * Kylix fixes, mostly case names of units

  Revision 1.9  2001/05/27 14:30:55  florian
    + some widestring stuff added

  Revision 1.8  2001/04/21 13:32:07  peter
    * remove endless loop with replacements (merged)

  Revision 1.7  2001/04/14 16:05:41  jonas
    * allow a single replacement string to be substituted more than once per
      message (already used in assembler reader messages for "fsub x" etc.
      transformations) (merged)

  Revision 1.6  2001/03/10 13:19:10  peter
    * don't check messagefile for numbers, this allows the usage of
      1.1 msgfiles with a 1.0.x compiler

  Revision 1.5  2000/11/29 00:30:31  florian
    * unused units removed from uses clause
    * some changes for widestrings

  Revision 1.4  2000/09/24 21:33:46  peter
    * message updates merges

  Revision 1.3  2000/09/24 15:06:18  peter
    * use defines.inc

  Revision 1.2  2000/07/13 11:32:43  michael
  + removed logs

}