Subversion Repositories autosfx

Rev

Blame | Last modification | View Log | RSS feed

  1. unit ZMMsgStr19;
  2.  
  3. (*
  4.   ZMMsgStr19.pas - message string handler
  5.     Copyright (C) 2009, 2010  by Russell J. Peters, Roger Aelbrecht,
  6.       Eric W. Engler and Chris Vleghert.
  7.  
  8.         This file is part of TZipMaster Version 1.9.
  9.  
  10.     TZipMaster is free software: you can redistribute it and/or modify
  11.     it under the terms of the GNU Lesser General Public License as published by
  12.     the Free Software Foundation, either version 3 of the License, or
  13.     (at your option) any later version.
  14.  
  15.     TZipMaster is distributed in the hope that it will be useful,
  16.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.     GNU Lesser General Public License for more details.
  19.  
  20.     You should have received a copy of the GNU Lesser General Public License
  21.     along with TZipMaster.  If not, see <http://www.gnu.org/licenses/>.
  22.  
  23.     contact: problems@delphizip.org (include ZipMaster in the subject).
  24.     updates: http://www.delphizip.org
  25.     DelphiZip maillist subscribe at http://www.freelists.org/list/delphizip
  26.  
  27.   modified 2010-03-15
  28.   --------------------------------------------------------------------------- *)
  29.  
  30. interface
  31.  
  32. uses
  33.   Classes, ZipMstr19, ZMCompat19;
  34.  
  35.  
  36. var
  37.   OnZMStr: TZMLoadStrEvent;
  38.  
  39. function LoadZipStr(id: Integer): String;
  40.  
  41. // '*' = Auto, '' = default US,  language  (number = language id)
  42. function SetZipMsgLanguage(const zl: String): String;
  43. // get language at index (<0 - default, 0 - current)
  44. function GetZipMsgLanguage(idx: Integer): String;
  45. // info (-1) = language id, 0 = name, other values as per windows LOCALE_
  46. function GetZipMsgLanguageInfo(idx: Integer; info: Cardinal): String;
  47.  
  48. function LanguageIdent(const seg: Ansistring): Ansistring;
  49. function LocaleInfo(loc: Integer; info: Cardinal): String;
  50.  
  51. implementation
  52.  
  53. uses
  54.   Windows, SysUtils,
  55. {$IFDEF UNICODE}
  56.   AnsiStrings,
  57. {$ELSE}
  58.   ZMUTF819,
  59. {$ENDIF}
  60.   ZMUtils19, ZMMsg19, ZMDefMsgs19, ZMExtrLZ7719;
  61.  
  62. {$I '.\ZMConfig19.inc'}
  63.  
  64. {$IFNDEF VERD6up}
  65. type
  66.   PCardinal = ^Cardinal;
  67. {$ENDIF}
  68.  
  69. const
  70.   SResourceMissingFor = 'Resource missing for ';
  71.   SUSDefault = 'US: default';
  72.   lchars = ['A' .. 'Z', 'a' .. 'z', '0' .. '9', '_'];
  73.   Uchars = ['a' .. 'z'];
  74.   Digits = ['0' .. '9'];
  75.  
  76. var
  77. {$IFDEF USE_COMPRESSED_STRINGS}
  78.   DefRes: TZMRawBytes; // default strings
  79. {$ENDIF}
  80.   SelRes: TZMRawBytes; // selected strings
  81.   SelId: Cardinal;
  82.   SelName: Ansistring;
  83.   Setting: bool;
  84.  
  85. function LanguageIdent(const seg: Ansistring): Ansistring;
  86. var
  87.   c: AnsiChar;
  88.   i: Integer;
  89. begin
  90.   Result := '';
  91.   for i := 1 to length(seg) do
  92.   begin
  93.     c := seg[i];
  94.     if not(c in lchars) then
  95.     begin
  96.       if (Result <> '') or (c <> ' ') then
  97.         break;
  98.     end
  99.     else
  100.     begin
  101.       if (Result = '') and (c in Digits) then
  102.         break; // must not start with digit
  103.       if c in Uchars then
  104.         c := AnsiChar(Ord(c) - $20); // convert to upper
  105.       Result := Result + c;
  106.     end;
  107.   end;
  108.   // Result := Uppercase(Result);
  109. end;
  110.  
  111. // format is
  112. // id: word, data_size: word, label_size: word, label: char[], data: byte[];... ;0
  113. // stream at id
  114. // returns id
  115. function LoadFromStream(var blk: TZMRawBytes; src: TStream): Cardinal;
  116. var
  117.   r: Integer;
  118.   so: TMemoryStream;
  119.   sz: array [0 .. 2] of Word;
  120.   szw: Integer;
  121. begin
  122.   blk := ''; // empty it
  123.   Result := 0;
  124.   if src.Read(sz[0], 3 * sizeof(Word)) <> (3 * sizeof(Word)) then
  125.     exit;
  126.   if src.Size < (sz[1] + sz[2] + (3 * sizeof(Word))) then
  127.     exit;
  128.   src.Position := src.Position + sz[2]; // skip name
  129.   try
  130.     so := TMemoryStream.Create;
  131.     r := LZ77Extract(so, src, sz[1]);
  132.     // Assert(r = 0, 'error extracting strings');
  133.     if (r = 0) and (so.Size < 50000) then
  134.     begin
  135.       szw := (Integer(so.Size) + (sizeof(Word) - 1));
  136.       SetLength(blk, szw + sizeof(Word));
  137.       so.Position := 0;
  138.       if so.Read(blk[1], so.Size) = so.Size then
  139.       begin
  140.         blk[szw + 1] := #255;
  141.         blk[szw + 2] := #255;
  142.         Result := sz[0];
  143.       end
  144.       else
  145.         blk := '';
  146.     end;
  147.   finally
  148.     FreeAndNil(so);
  149.   end;
  150. end;
  151.  
  152. // format is
  153. // id: word, data_size: word, label_size: word, label: char[], data: byte[];... ;0
  154. // positions stream to point to id
  155. // SegName has identifier terminated by ':'
  156. function FindInStream(src: TStream; var SegName: Ansistring; var LangId: Word)
  157.   : Boolean;
  158. var
  159.   c: AnsiChar;
  160.   i: Word;
  161.   p: Int64;
  162.   s: Ansistring;
  163.   seg: Ansistring;
  164.   ss: Int64;
  165.   uname: Ansistring;
  166.   w: Word;
  167.   w3: array [0 .. 2] of Word;
  168. begin
  169.   Result := False;
  170.   if not assigned(src) then
  171.     exit;
  172.   seg := LanguageIdent(SegName);
  173.   if (length(seg) < 2) and (LangId = 0) then
  174.     exit;
  175.   uname := '';
  176.   for i := 1 to length(SegName) do
  177.   begin
  178.     c := SegName[i];
  179.     if c in Uchars then
  180.       c := AnsiChar(Ord(c) - $20);
  181.     uname := uname + c;
  182.   end;
  183.   p := src.Position;
  184.   ss := src.Size - ((3 * sizeof(Word)) + 2); // id + dlen + nlen + min 2 chars
  185.   while (not Result) and (p < ss) do
  186.   begin
  187.     src.Position := p;
  188.     src.ReadBuffer(w3[0], 3 * sizeof(Word)); // id, dsize, nsize
  189.     w := w3[2]; // name size
  190.     if w > 0 then
  191.     begin
  192.       SetLength(s, w);
  193.       src.ReadBuffer(s[1], w); // read name
  194.     end;
  195.     if LangId = 0 then
  196.     begin
  197.       // find by name
  198.       Result := False;
  199.       for i := 1 to w do
  200.       begin
  201.         c := s[i];
  202.         if not(c in lchars) then
  203.           break;
  204.         if i > length(uname) then
  205.         begin
  206.           Result := False;
  207.           break;
  208.         end;
  209.         if c in Uchars then
  210.           c := AnsiChar(Ord(c) - $20);
  211.         Result := c = uname[i];
  212.         if not Result then
  213.           break;
  214.       end;
  215.     end
  216.     else // find by language ID
  217.       Result := (LangId = w3[0]) or
  218.         ((LangId < $400) and ((w3[0] and $3FF) = LangId));
  219.     if not Result then
  220.       p := src.Position + w3[1]; // skip data to next entry
  221.   end;
  222.   if Result then
  223.   begin
  224.     SegName := s;
  225.     LangId := w3[0];
  226.     src.Position := p;
  227.   end;
  228. end;
  229.  
  230. // format is
  231. // id: word, data_size: word, label_size: word, label: char[], data: byte[];... ;0
  232. // positions stream to point to id
  233. // segname has identifier terminated by ':'
  234. function IdInStream(src: TStream; var idx: Cardinal; var lang: String): Boolean;
  235. var
  236.   p: Int64;
  237.   s: Ansistring;
  238.   ss: Int64;
  239.   w3: array [0 .. 2] of Word;
  240. begin
  241.   Result := False;
  242.   if (idx < 1) or not assigned(src) then
  243.     exit;
  244.   p := src.Position;
  245.   ss := src.Size - ((3 * sizeof(Word)) + 20); // id + dlen + nlen + 20 bytes
  246.   if p > ss then
  247.     exit;
  248.   repeat
  249.     src.ReadBuffer(w3[0], 3 * sizeof(Word)); // id, dsize, nsize
  250.     if idx <= 1 then
  251.       break;
  252.     Dec(idx);
  253.     p := src.Position + w3[1] + w3[2]; // after name + data
  254.     if p < ss then
  255.       src.Position := p
  256.     else
  257.       exit;
  258.   until False;
  259.   SetLength(s, w3[2]);
  260.   src.ReadBuffer(s[1], w3[2]); // read name
  261.   lang := String(s);
  262.   idx := w3[0];
  263.   src.Position := p;
  264.   Result := True;
  265. end;
  266.  
  267. {$IFNDEF VERD6up}
  268. function TryStrToInt(const s: String; var v: Integer): Boolean;
  269. begin
  270.   if (s = '') or not CharInSet(s[1], ['0' .. '9', '$']) then
  271.     Result := False
  272.   else
  273.   begin
  274.     Result := True;
  275.     try
  276.       v := StrToInt(s);
  277.     except
  278.       on EConvertError do
  279.         Result := False;
  280.     end;
  281.   end;
  282. end;
  283. {$ENDIF}
  284.  
  285. function SetZipMsgLanguage(const zl: String): String;
  286. var
  287.   i: Integer;
  288.   id: Word;
  289.   len: Integer;
  290.   LangName: Ansistring;
  291.   newBlock: TZMRawBytes;
  292.   newId: Cardinal;
  293.   newres: TZMRawBytes;
  294.   res: TResourceStream;
  295. begin
  296.   if (zl = '') or Setting then
  297.     exit;
  298.   res := nil;
  299.   try
  300.     Setting := True;
  301.     SelRes := ''; // reset to default
  302.     SelId := 0;
  303.     SelName := '';
  304.     Result := '';
  305.     id := 0;
  306.     LangName := LanguageIdent(Ansistring(zl));
  307.     if (length(LangName) < 2) then
  308.     begin
  309.       if zl = '*' then
  310.         id := GetUserDefaultLCID
  311.       else
  312.       begin
  313.         if (not TryStrToInt(zl, i)) or (i <= 0) or (i > $0FFFF) then
  314.           exit;
  315.         id := Cardinal(i);
  316.       end;
  317.     end;
  318.     if (LangName <> 'US') and (id <> $0409) then // use default US
  319.     begin
  320.       res := OpenResStream(DZRES_Str, RT_RCData);
  321.       if assigned(res) and FindInStream(res, LangName, id) then
  322.       begin
  323.         newId := LoadFromStream(newBlock, res);
  324.         if newId > 0 then
  325.         begin
  326.           len := length(newBlock);
  327.           SetLength(newres, len);
  328.           Move(newBlock[1], PAnsiChar(newres)^, len);
  329.           Result := String(LangName);
  330.           SelRes := newres;
  331.           SelName := LangName;
  332.           SelId := newId;
  333.         end;
  334.       end;
  335.     end;
  336.   finally
  337.     Setting := False;
  338.     FreeAndNil(res);
  339.   end;
  340. end;
  341.  
  342. function LocaleInfo(loc: Integer; info: Cardinal): String;
  343. var
  344.   s: String;
  345. begin
  346.   if (loc <= 0) or (loc = $400) then
  347.     loc := LOCALE_USER_DEFAULT;
  348.   SetLength(s, 1024);
  349.   GetLocaleInfo(loc and $FFFF, info, PChar(s), 1023);
  350.   Result := PChar(s); // remove any trailing #0
  351. end;
  352.  
  353. // get language at Idx (<0 - default, 0 - current)
  354. // info (-1) = language id, 0 = name, other values as per windows LOCALE_
  355. function GetZipMsgLanguageInfo(idx: Integer; info: Cardinal): String;
  356. var
  357.   id: Cardinal;
  358.   res: TResourceStream;
  359.   s: String;
  360. begin
  361.   id := $0409;
  362.   Result := SUSDefault; // default US English
  363.   if (idx = 0) and (SelRes <> '') then
  364.   begin
  365.     Result := String(SelName);
  366.     id := SelId;
  367.   end;
  368.   if idx > 0 then
  369.   begin
  370.     res := nil;
  371.     Result := '><';
  372.     id := idx and $FF;
  373.     try
  374.       res := OpenResStream(DZRES_Str, RT_RCData);
  375.       if assigned(res) and IdInStream(res, id, s) then
  376.         Result := s;
  377.     finally
  378.       FreeAndNil(res);
  379.     end;
  380.   end;
  381.   if Result <> '><' then
  382.   begin
  383.     if info = 0 then
  384.       Result := '$' + IntToHex(id, 4)
  385.     else if info <> Cardinal(-1) then
  386.       Result := LocaleInfo(id, info);
  387.   end;
  388. end;
  389.  
  390. // get language at index (<0 - current, 0 - default, >0 - index)
  391. function GetZipMsgLanguage(idx: Integer): String;
  392. begin
  393.   Result := GetZipMsgLanguageInfo(idx, Cardinal(-1));
  394. end;
  395.  
  396. // Delphi does not like adding offset
  397. function _ofsp(blk: PWord; ofs: Integer): PWord;
  398. begin
  399.   Result := blk;
  400.   inc(Result, ofs);
  401. end;
  402.  
  403. // returns String
  404. function FindRes1(blkstr: TZMRawBytes; id: Integer): String;
  405. var
  406.   blkP: PWord;
  407.   bp: Integer;
  408.   DatSiz: Cardinal;
  409.   fid: Integer;
  410.   HedSiz: Cardinal;
  411.   hp: Integer;
  412.   l: Cardinal;
  413.   mx: Integer;
  414.   rid: Integer;
  415.   sz: Cardinal;
  416.   ws: WideString;
  417. begin
  418.   Result := '';
  419.   if blkstr = '' then
  420.     exit;
  421.   fid := id div 16;
  422.   try
  423.     blkP := PWord(PAnsiChar(blkstr));
  424.     bp := 0;
  425.     mx := length(blkstr) div sizeof(Word);
  426.     while (bp + 9) < mx do
  427.     begin
  428.       bp := (bp + 1) and $7FFFE; // dword align
  429.       DatSiz := pCardinal(_ofsp(blkP, bp))^;
  430.       HedSiz := pCardinal(_ofsp(blkP, bp + 2))^;
  431.       if (HedSiz + DatSiz) < 8 then
  432.         break;
  433.       // Assert((HedSiz + DatSiz) >= 8, 'header error');
  434.       sz := (HedSiz + DatSiz) - 8;
  435.       hp := bp + 4;
  436.       inc(bp, 4 + (sz div 2));
  437.       if _ofsp(blkP, hp)^ <> $FFFF then
  438.         continue; // bad res type
  439.       if _ofsp(blkP, hp + 1)^ <> 6 then
  440.         continue; // not string table
  441.       if _ofsp(blkP, hp + 2)^ <> $FFFF then
  442.         continue;
  443.       rid := pred(_ofsp(blkP, hp + 3)^);
  444.       if fid <> rid then
  445.         continue;
  446.       rid := rid * 16;
  447.       inc(hp, (HedSiz - 8) div 2);
  448.       ws := '';
  449.       while rid < id do
  450.       begin
  451.         l := _ofsp(blkP, hp)^;
  452.         inc(hp, l + 1);
  453.         inc(rid);
  454.       end;
  455.       l := _ofsp(blkP, hp)^;
  456.       if l <> 0 then
  457.       begin
  458.         SetLength(ws, l);
  459.         Move(_ofsp(blkP, hp + 1)^, ws[1], l * sizeof(Widechar));
  460.         Result := ws;
  461.         Result := StringReplace(Result, #10, #13#10, [rfReplaceAll]);
  462.         break;
  463.       end;
  464.       break;
  465.     end;
  466.   except
  467.     Result := '';
  468.   end;
  469. end;
  470. {$IFNDEF USE_COMPRESSED_STRINGS}
  471.  
  472. function FindConst(id: Integer): String;
  473. var
  474.   p: pResStringRec;
  475.  
  476.   function Find(idx: Integer): pResStringRec;
  477.   var
  478.     wi: Word;
  479.     i: Integer;
  480.   begin
  481.     Result := nil;
  482.     wi := Word(idx);
  483.     for i := 0 to high(ResTable) do
  484.       if ResTable[i].i = wi then
  485.       begin
  486.         Result := ResTable[i].s;
  487.         break;
  488.       end;
  489.   end;
  490.  
  491. begin { FindConst }
  492.   Result := '';
  493.   if id < 10000 then
  494.     exit;
  495.   p := Find(id);
  496.   if p <> nil then
  497.     Result := LoadResString(p);
  498. end;
  499. {$ELSE}
  500.  
  501. // format is
  502. // id: word, data_size: word, label_size: word, label: char[], data: byte[];... ;0
  503. function LoadCompressedDef(const src): Integer;
  504. var
  505.   ms: TMemoryStream;
  506.   w: Word;
  507.   pw: PWord;
  508. begin
  509.   Result := -1;
  510.   pw := @src;
  511.   if pw^ = $0409 then
  512.   begin
  513.     inc(pw);
  514.     w := pw^;
  515.     inc(pw);
  516.     inc(w, pw^);
  517.     inc(w, (3 * sizeof(Word)));
  518.     try
  519.       ms := TMemoryStream.Create;
  520.       ms.Write(src, w);
  521.       ms.Position := 0;
  522.       Result := LoadFromStream(DefRes, ms);
  523.     finally
  524.       FreeAndNil(ms);
  525.     end;
  526.   end;
  527. end;
  528. {$ENDIF}
  529.  
  530. // returns String
  531. function LoadZipStr(id: Integer): String;
  532. var
  533.   d: String;
  534.   blk: TZMRawBytes;
  535.   tmpOnZipStr: TZMLoadStrEvent;
  536. begin
  537.   Result := '';
  538.   blk := SelRes;
  539.   Result := FindRes1(blk, id);
  540. {$IFDEF USE_COMPRESSED_STRINGS}
  541.   if Result = '' then
  542.   begin
  543.     if DefRes = '' then
  544.       LoadCompressedDef(CompBlok);
  545.     blk := DefRes;
  546.     Result := FindRes1(blk, id);
  547.   end;
  548. {$ELSE}
  549.   if Result = '' then
  550.     Result := FindConst(id);
  551. {$ENDIF}
  552.   tmpOnZipStr := OnZMStr;
  553.   if assigned(tmpOnZipStr) then
  554.   begin
  555.     d := Result;
  556.     tmpOnZipStr(id, d);
  557.     if d <> '' then
  558.       Result := d;
  559.   end;
  560.   if Result = '' then
  561.     Result := SResourceMissingFor + IntToStr(id);
  562. end;
  563.  
  564. initialization
  565.   OnZMStr := nil;
  566.   Setting := False;
  567. {$IFDEF USE_COMPRESSED_STRINGS}
  568.   DefRes := '';
  569. {$ENDIF}
  570.   SelRes := '';
  571.  
  572. finalization
  573. {$IFDEF USE_COMPRESSED_STRINGS}
  574.   DefRes := ''; // force destruction
  575. {$ENDIF}
  576.   SelRes := '';
  577.  
  578. end.
  579.