fpc/compiler/cresstr.pas

{
    Copyright (c) 1998-2002 by Michael van Canneyt

    Handles resourcestrings

    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 cresstr;

{$i fpcdefs.inc}

interface

    Procedure GenerateResourceStrings;


implementation

uses
   SysUtils,
   cclasses,widestr,
   cutils,globtype,globals,systems,
   symbase,symconst,symtype,defutil, symdef,symsym,symtable,
   verbose,fmodule,ppu,
   aasmtai,aasmdata,aasmcnst,
   aasmcpu;

    Type
      { These are used to form a singly-linked list, ordered by hash value }
      TResourceStringItem = class(TLinkedListItem)
        Sym   : TConstSym;
        Name  : String;
        AValue : TAnsiCharDynArray;
        WValue : pcompilerwidestring; // just a reference, do not free.
        Len   : Longint; // in bytes, not characters
        hash  : Cardinal;
        isUnicode : Boolean;
        constructor Create(asym:TConstsym);
        destructor  Destroy;override;
        procedure CalcHash;
      end;

      Tresourcestrings=class
      private
        List : TLinkedList;
        procedure ConstSym_Register(p:TObject;arg:pointer);
      public
        constructor Create;
        destructor  Destroy;override;
        procedure CreateResourceStringData;
        procedure WriteRSJFile;
        procedure RegisterResourceStrings;
      end;



{ ---------------------------------------------------------------------
                          TRESOURCESTRING_ITEM
  ---------------------------------------------------------------------}

    constructor TResourceStringItem.Create(asym:TConstsym);

    var
      pw : pcompilerwidestring;
      t : TDef;

      begin
        inherited Create;
        Sym:=Asym;
        Name:=lower(asym.owner.name^+'.'+asym.Name);
        isUnicode:=is_systemunit_unicode;
        if IsUnicode then
          begin
          T:=aSym.constdef;
          WValue:=pcompilerwidestring(asym.value.valueptr);
          Len:=WValue^.len*sizeOf(tcompilerwidechar);
          end
        else
          begin
          Len:=asym.value.len;
          SetLength(AValue,Len);
          Move(asym.value.valueptr^,AValue[0],Len);
          end;
        CalcHash;
      end;


    destructor TResourceStringItem.Destroy;
      begin
        AValue:=nil;
      end;


    procedure TResourceStringItem.CalcHash;
      Var
        g : Cardinal;
        llen,wlen,I : longint;
        P : PByte;
        pc : PAnsiChar;

      begin
        pc:=nil;
        hash:=0;
        if IsUnicode then
          begin
          // Need to calculate hash on UTF8 encoded string, GNU gettext.
          llen:=UnicodeToUtf8(nil,0,PUnicodeChar(wValue^.data),wValue^.len);
          getmem(pc,llen);
          UnicodeToUtf8(PC,llen,PUnicodeChar(wValue^.data),len);
          P:=PByte(pc);
          llen:=llen-1; // Take of terminating #0
          end
        else
          begin
          llen:=Len;
          P:=PByte(AValue);
          end;
        For I:=0 to lLen-1 do { 0 terminated }
         begin
           hash:=hash shl 4;
           inc(Hash,P[i]);
           g:=hash and ($f shl 28);
           if g<>0 then
            begin
              hash:=hash xor (g shr 24);
              hash:=hash xor g;
            end;
         end;
        if Assigned(Pc) then
          FreeMem(PC);
        If Hash=0 then
          Hash:=$ffffffff;
      end;


{ ---------------------------------------------------------------------
                          Tresourcestrings
  ---------------------------------------------------------------------}

    Constructor Tresourcestrings.Create;
      begin
        List:=TAsmList.Create;
      end;


    Destructor Tresourcestrings.Destroy;
      begin
        List.Free;
      end;


    procedure Tresourcestrings.CreateResourceStringData;
      Var
        namelab,
        valuelab : tasmlabofs;
        R : TResourceStringItem;
        resstrdef: tdef;
        tcb : ttai_typedconstbuilder;
        enc : tstringencoding;

      begin
        resstrdef:=search_system_type('TRESOURCESTRINGRECORD').typedef;

        tcb:=ctai_typedconstbuilder.create([tcalo_vectorized_dead_strip_start,tcalo_data_force_indirect,tcalo_is_public_asm]);
        { Write unitname entry }
        tcb.maybe_begin_aggregate(resstrdef);
        namelab:=tcb.emit_ansistring_const(current_asmdata.asmlists[al_const],@current_module.localsymtable.name^[1],length(current_module.localsymtable.name^),getansistringcodepage);
        tcb.emit_string_offset(namelab,length(current_module.localsymtable.name^),st_ansistring,false,charpointertype);
        tcb.emit_tai(tai_const.create_nil_dataptr,cansistringtype);
        tcb.emit_tai(tai_const.create_nil_dataptr,cansistringtype);
        tcb.emit_ord_const(0,u32inttype);
        tcb.maybe_end_aggregate(resstrdef);
        current_asmdata.asmlists[al_resourcestrings].concatList(
          tcb.get_final_asmlist_vectorized_dead_strip(
            nil,resstrdef,'RESSTR','',current_module.localsymtable,sizeof(pint)
          )
        );
        tcb.free;

        { Add entries }
        R:=TResourceStringItem(List.First);
        while assigned(R) do
          begin
            tcb:=ctai_typedconstbuilder.create([tcalo_vectorized_dead_strip_item,tcalo_data_force_indirect]);
            valuelab.lab:=nil;
            valuelab.ofs:=0;
            if (R.len<>0) then
              begin
              if R.isUnicode and assigned(R.WValue) then
                begin
                enc:=tstringdef(cunicodestringtype).encoding;
                valuelab:=tcb.emit_unicodestring_const(current_asmdata.asmlists[al_const],R.WValue,enc,False);
                end
              else
                begin
                if assigned(R.AValue) then
                  valuelab:=tcb.emit_ansistring_const(current_asmdata.asmlists[al_const],PAnsiChar(R.AValue),R.Len,getansistringcodepage)
                end;
              end;
            current_asmdata.asmlists[al_const].concat(cai_align.Create(sizeof(pint)));
            namelab:=tcb.emit_ansistring_const(current_asmdata.asmlists[al_const],@R.Name[1],length(R.name),getansistringcodepage);
            {
              Resourcestring index:
                  TResourceStringRecord = Packed Record
                     Name,
                     CurrentValue,
                     DefaultValue : AnsiString/Widestring;
                     HashValue    : LongWord;
                   end;
            }
            tcb.maybe_begin_aggregate(resstrdef);
            tcb.emit_string_offset(namelab,length(R.name),st_ansistring,false,charpointertype);
            tcb.emit_string_offset(valuelab,R.Len,st_ansistring,false,charpointertype);
            tcb.emit_string_offset(valuelab,R.Len,st_ansistring,false,charpointertype);
            tcb.emit_ord_const(R.hash,u32inttype);
            tcb.maybe_end_aggregate(resstrdef);
            current_asmdata.asmlists[al_resourcestrings].concatList(
              tcb.get_final_asmlist_vectorized_dead_strip(
                R.Sym,resstrdef,'RESSTR',R.Sym.Name,R.Sym.Owner,sizeof(pint))
            );
            R:=TResourceStringItem(R.Next);
            tcb.free;
          end;
        tcb:=ctai_typedconstbuilder.create([tcalo_vectorized_dead_strip_end,tcalo_data_force_indirect,tcalo_is_public_asm]);
        tcb.begin_anonymous_record(internaltypeprefixName[itp_emptyrec],
          default_settings.packrecords,sizeof(pint),
          targetinfos[target_info.system]^.alignment.recordalignmin);
        current_asmdata.AsmLists[al_resourcestrings].concatList(
          tcb.get_final_asmlist_vectorized_dead_strip(
            nil,tcb.end_anonymous_record,'RESSTR','',current_module.localsymtable,sizeof(pint)
          )
        );
        tcb.free;
      end;

    procedure Tresourcestrings.WriteRSJFile;
      Var
        F: Text;
        R: TResourceStringItem;
        ResFileName: string;
        I,Len: Integer;
        C: tcompilerwidechar;
        W: pcompilerwidestring;
        P : PByte;

      begin
        ResFileName:=ChangeFileExt(current_module.ppufilename,'.rsj');
        message1 (general_i_writingresourcefile,ExtractFileName(ResFileName));
        Assign(F,ResFileName);
        {$push}{$i-}
        Rewrite(f);
        {$pop}
        if IOresult<>0 then
          begin
            message1(general_e_errorwritingresourcefile,ResFileName);
            exit;
          end;
        { write the data in two formats:
           a) backward compatible: the plain bytes from the source file
           b) portable: converted to utf-16
        }
        writeln(f,'{"version":1,"strings":[');
        R:=TResourceStringItem(List.First);
        while assigned(R) do
          begin
            write(f, '{"hash":',R.Hash,',"name":"',R.Name,'","sourcebytes":[');
            if R.isUnicode then
              P:=PByte(R.WValue^.data)
            else
              P:=PByte(R.AValue);
            for i:=0 to R.Len-1 do
              begin
                write(f,P[i]);
                if i<>R.Len-1 then
                  write(f,',');
              end;
            write(f,'],"value":"');
            if Not r.isUnicode then
              begin
              initwidestring(W);
              ascii2unicode(PAnsiChar(R.AValue),R.Len,current_settings.sourcecodepage,W);
              end
            else
              begin
              W:=R.WValue;
              end;
            for I := 0 to W^.len - 1 do
              begin
                C := W^.Data[I];
                case C of
                  Ord('"'), Ord('\'), Ord('/'):
                    write(f, '\', Chr(C));
                  8:
                    write(f, '\b');
                  9:
                    write(f, '\t');
                  10:
                    write(f, '\n');
                  13:
                    write(f, '\r');
                  12:
                    write(f, '\f');
                  else
                  if (C < 32) or (C > 127) then
                    write(f,'\u',hexStr(Longint(C), 4))
                  else
                    write(f,Chr(C));
                end;
              end;
            if W<>R.WValue then
              donewidestring(W);
            write(f,'"}');
            R:=TResourceStringItem(R.Next);
            if assigned(R) then
              writeln(f,',')
            else
              writeln(f);
          end;
        writeln(f,']}');
        close(f);
      end;

    procedure Tresourcestrings.ConstSym_Register(p:TObject;arg:pointer);
      begin
        if (tsym(p).typ=constsym) and
           (tconstsym(p).consttyp in [constresourcestring,constwresourcestring]) then
          List.Concat(TResourceStringItem.Create(TConstsym(p)));
      end;


    procedure Tresourcestrings.RegisterResourceStrings;
      begin
        if assigned(current_module.globalsymtable) then
          current_module.globalsymtable.SymList.ForEachCall(@ConstSym_Register,nil);
        current_module.localsymtable.SymList.ForEachCall(@ConstSym_Register,nil);
      end;


    Procedure GenerateResourceStrings;
      var
        resstrs : Tresourcestrings;
      begin
        { needed for the typed constant defs that get generated/looked up }
        if assigned(current_module.globalsymtable) then
          symtablestack.push(current_module.globalsymtable);
        symtablestack.push(current_module.localsymtable);
        resstrs:=Tresourcestrings.Create;
        resstrs.RegisterResourceStrings;
        if not resstrs.List.Empty then
          begin
            include(current_module.moduleflags,mf_has_resourcestrings);
            resstrs.CreateResourceStringData;
            resstrs.WriteRSJFile;
          end;
        resstrs.Free;
        symtablestack.pop(current_module.localsymtable);
        if assigned(current_module.globalsymtable) then
          symtablestack.pop(current_module.globalsymtable);
      end;

end.