cmsgs.pas 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Peter Vreman
  4. This unit implements the message object
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit cmsgs;
  19. {$i fpcdefs.inc}
  20. interface
  21. const
  22. maxmsgidxparts = 20;
  23. type
  24. ppchar=^pchar;
  25. TArrayOfPChar = array[0..1000] of pchar;
  26. PArrayOfPChar = ^TArrayOfPChar;
  27. PMessage=^TMessage;
  28. TMessage=object
  29. msgfilename : string;
  30. msgintern : boolean;
  31. msgallocsize,
  32. msgsize,
  33. msgparts,
  34. msgs : longint;
  35. msgtxt : pchar;
  36. msgidx : array[1..maxmsgidxparts] of PArrayOfPChar;
  37. msgidxmax : array[1..maxmsgidxparts] of longint;
  38. constructor Init(n:longint;const idxmax:array of longint);
  39. destructor Done;
  40. function LoadIntern(p:pointer;n:longint):boolean;
  41. function LoadExtern(const fn:string):boolean;
  42. procedure ClearIdx;
  43. procedure CreateIdx;
  44. function GetPChar(nr:longint):pchar;
  45. function Get(nr:longint):string;
  46. function Get4(nr:longint;const s1,s2,s3,s4:string):string;
  47. function Get3(nr:longint;const s1,s2,s3:string):string;
  48. function Get2(nr:longint;const s1,s2:string):string;
  49. function Get1(nr:longint;const s1:string):string;
  50. end;
  51. { this will read a line until #10 or #0 and also increase p }
  52. function GetMsgLine(var p:pchar):string;
  53. implementation
  54. uses
  55. cutils,
  56. {$ifdef DELPHI}
  57. sysutils;
  58. {$else DELPHI}
  59. strings;
  60. {$endif DELPHI}
  61. function MsgReplace(const s,s1,s2,s3,s4:string):string;
  62. var
  63. last,
  64. i : longint;
  65. hs : string;
  66. begin
  67. if s='' then
  68. begin
  69. MsgReplace:='';
  70. exit;
  71. end;
  72. hs:='';
  73. i:=0;
  74. last:=0;
  75. while (i<length(s)-1) do
  76. begin
  77. inc(i);
  78. if (s[i]='$') and
  79. (s[i+1] in ['1'..'4']) then
  80. begin
  81. hs:=hs+copy(s,last+1,i-last-1);
  82. case s[i+1] of
  83. '1' :
  84. hs:=hs+s1;
  85. '2' :
  86. hs:=hs+s2;
  87. '3' :
  88. hs:=hs+s3;
  89. '4' :
  90. hs:=hs+s4;
  91. end;
  92. inc(i);
  93. last:=i;
  94. end;
  95. end;
  96. MsgReplace:=hs+copy(s,last+1,length(s)-last);;
  97. end;
  98. constructor TMessage.Init(n:longint;const idxmax:array of longint);
  99. var
  100. i : longint;
  101. begin
  102. msgtxt:=nil;
  103. msgsize:=0;
  104. msgparts:=n;
  105. if n<>high(idxmax)+1 then
  106. fail;
  107. for i:=1 to n do
  108. begin
  109. msgidxmax[i]:=idxmax[i-1];
  110. getmem(msgidx[i],msgidxmax[i]*4);
  111. fillchar(msgidx[i]^,msgidxmax[i]*4,0);
  112. end;
  113. end;
  114. destructor TMessage.Done;
  115. var
  116. i : longint;
  117. begin
  118. for i:=1 to msgparts do
  119. freemem(msgidx[i],msgidxmax[i]*4);
  120. if msgallocsize>0 then
  121. begin
  122. freemem(msgtxt,msgsize);
  123. msgallocsize:=0;
  124. end;
  125. msgtxt:=nil;
  126. msgsize:=0;
  127. msgparts:=0;
  128. end;
  129. function TMessage.LoadIntern(p:pointer;n:longint):boolean;
  130. begin
  131. msgtxt:=pchar(p);
  132. msgsize:=n;
  133. msgallocsize:=0;
  134. msgintern:=true;
  135. ClearIdx;
  136. CreateIdx;
  137. LoadIntern:=true;
  138. end;
  139. function TMessage.LoadExtern(const fn:string):boolean;
  140. {$ifndef FPC}
  141. procedure readln(var t:text;var s:string);
  142. var
  143. c : char;
  144. i : longint;
  145. begin
  146. c:=#0;
  147. i:=0;
  148. while (not eof(t)) and (c<>#10) do
  149. begin
  150. read(t,c);
  151. if c<>#10 then
  152. begin
  153. inc(i);
  154. s[i]:=c;
  155. end;
  156. end;
  157. if (i>0) and (s[i]=#13) then
  158. dec(i);
  159. s[0]:=chr(i);
  160. end;
  161. {$endif}
  162. const
  163. bufsize=8192;
  164. var
  165. f : text;
  166. error,multiline : boolean;
  167. line,i,j : longint;
  168. ptxt : pchar;
  169. s,s1 : string;
  170. buf : pointer;
  171. procedure err(const msgstr:string);
  172. begin
  173. writeln('*** PPC, file ',fn,', error in line ',line,': ',msgstr);
  174. error:=true;
  175. end;
  176. begin
  177. LoadExtern:=false;
  178. getmem(buf,bufsize);
  179. {Read the message file}
  180. assign(f,fn);
  181. {$I-}
  182. reset(f);
  183. {$I+}
  184. if ioresult<>0 then
  185. begin
  186. WriteLn('*** PPC, can not open message file ',fn);
  187. exit;
  188. end;
  189. settextbuf(f,buf^,bufsize);
  190. { First parse the file and count bytes needed }
  191. error:=false;
  192. line:=0;
  193. multiline:=false;
  194. msgsize:=0;
  195. while not eof(f) do
  196. begin
  197. readln(f,s);
  198. inc(line);
  199. if multiline then
  200. begin
  201. if s=']' then
  202. multiline:=false
  203. else
  204. inc(msgsize,length(s)+1); { +1 for linebreak }
  205. end
  206. else
  207. begin
  208. if (s<>'') and not(s[1] in ['#',';','%']) then
  209. begin
  210. i:=pos('=',s);
  211. if i>0 then
  212. begin
  213. j:=i+1;
  214. if not(s[j] in ['0'..'9']) then
  215. err('no number found')
  216. else
  217. begin
  218. while (s[j] in ['0'..'9']) do
  219. inc(j);
  220. end;
  221. if j-i-1<>5 then
  222. err('number length is not 5');
  223. if s[j+1]='[' then
  224. begin
  225. inc(msgsize,j-i);
  226. multiline:=true
  227. end
  228. else
  229. inc(msgsize,length(s)-i+1);
  230. end
  231. else
  232. err('no = found');
  233. end;
  234. end;
  235. end;
  236. if multiline then
  237. err('still in multiline mode');
  238. if error then
  239. begin
  240. freemem(buf,bufsize);
  241. close(f);
  242. exit;
  243. end;
  244. { now read the buffer in mem }
  245. msgallocsize:=msgsize;
  246. getmem(msgtxt,msgallocsize);
  247. ptxt:=msgtxt;
  248. reset(f);
  249. while not eof(f) do
  250. begin
  251. readln(f,s);
  252. if multiline then
  253. begin
  254. if s=']' then
  255. begin
  256. multiline:=false;
  257. { overwrite last eol }
  258. dec(ptxt);
  259. ptxt^:=#0;
  260. inc(ptxt);
  261. end
  262. else
  263. begin
  264. move(s[1],ptxt^,length(s));
  265. inc(ptxt,length(s));
  266. ptxt^:=#10;
  267. inc(ptxt);
  268. end;
  269. end
  270. else
  271. begin
  272. if (s<>'') and not(s[1] in ['#',';','%']) then
  273. begin
  274. i:=pos('=',s);
  275. if i>0 then
  276. begin
  277. j:=i+1;
  278. while (s[j] in ['0'..'9']) do
  279. inc(j);
  280. { multiline start then no txt }
  281. if s[j+1]='[' then
  282. begin
  283. s1:=Copy(s,i+1,j-i);
  284. move(s1[1],ptxt^,length(s1));
  285. inc(ptxt,length(s1));
  286. multiline:=true;
  287. end
  288. else
  289. begin
  290. { txt including number }
  291. s1:=Copy(s,i+1,255);
  292. move(s1[1],ptxt^,length(s1));
  293. inc(ptxt,length(s1));
  294. ptxt^:=#0;
  295. inc(ptxt);
  296. end;
  297. end;
  298. end;
  299. end;
  300. end;
  301. close(f);
  302. freemem(buf,bufsize);
  303. { now we can create the index, clear if the previous load was also
  304. an external file, because those can't be reused }
  305. if not msgintern then
  306. ClearIdx;
  307. CreateIdx;
  308. { set that we've loaded an external file }
  309. msgintern:=false;
  310. LoadExtern:=true;
  311. end;
  312. procedure TMessage.ClearIdx;
  313. var
  314. i : longint;
  315. begin
  316. { clear }
  317. for i:=1to msgparts do
  318. fillchar(msgidx[i]^,msgidxmax[i]*4,0);
  319. end;
  320. procedure TMessage.CreateIdx;
  321. var
  322. hp1,
  323. hp,hpend : pchar;
  324. code : integer;
  325. num : longint;
  326. number : string[5];
  327. i : longint;
  328. numpart,numidx : longint;
  329. begin
  330. { process msgtxt buffer }
  331. number:='00000';
  332. hp:=msgtxt;
  333. hpend:=@msgtxt[msgsize];
  334. while (hp<hpend) do
  335. begin
  336. hp1:=hp;
  337. for i:=1to 5 do
  338. begin
  339. number[i]:=hp1^;
  340. inc(hp1);
  341. end;
  342. val(number,num,code);
  343. numpart:=num div 1000;
  344. numidx:=num mod 1000;
  345. { check range }
  346. if (numpart <= msgparts) and (numidx < msgidxmax[numpart]) then
  347. begin
  348. { skip _ }
  349. inc(hp1);
  350. { put the address in the idx, the numbers are already checked }
  351. msgidx[numpart]^[numidx]:=hp1;
  352. end;
  353. { next string }
  354. hp:=pchar(@hp[strlen(hp)+1]);
  355. end;
  356. end;
  357. function GetMsgLine(var p:pchar):string;
  358. var
  359. i : longint;
  360. begin
  361. i:=0;
  362. while not(p^ in [#0,#10]) and (i<255) do
  363. begin
  364. inc(i);
  365. GetMsgLine[i]:=p^;
  366. inc(p);
  367. end;
  368. { skip #10 }
  369. if p^=#10 then
  370. inc(p);
  371. { if #0 then set p to nil }
  372. if p^=#0 then
  373. p:=nil;
  374. { return string }
  375. GetMsgLine[0]:=chr(i);
  376. end;
  377. function TMessage.GetPChar(nr:longint):pchar;
  378. begin
  379. GetPChar:=msgidx[nr div 1000]^[nr mod 1000];
  380. end;
  381. function TMessage.Get(nr:longint):string;
  382. var
  383. s : string[16];
  384. hp : pchar;
  385. begin
  386. hp:=msgidx[nr div 1000]^[nr mod 1000];
  387. if hp=nil then
  388. begin
  389. Str(nr,s);
  390. Get:='msg nr '+s;
  391. end
  392. else
  393. Get:=StrPas(hp);
  394. end;
  395. function TMessage.Get4(nr:longint;const s1,s2,s3,s4:string):string;
  396. begin
  397. Get4:=MsgReplace(Get(nr),s1,s2,s3,s4);
  398. end;
  399. function TMessage.Get3(nr:longint;const s1,s2,s3:string):string;
  400. begin
  401. Get3:=MsgReplace(Get(nr),s1,s2,s3,'');
  402. end;
  403. function TMessage.Get2(nr:longint;const s1,s2:string):string;
  404. begin
  405. Get2:=MsgReplace(Get(nr),s1,s2,'','');
  406. end;
  407. function TMessage.Get1(nr:longint;const s1:string):string;
  408. begin
  409. Get1:=MsgReplace(Get(nr),s1,'','','');
  410. end;
  411. end.
  412. {
  413. $Log$
  414. Revision 1.8 2003-05-10 23:57:23 florian
  415. * vmtpointer_offset must be adjusted in after_pass1 as well
  416. Revision 1.7 2003/04/22 14:33:38 peter
  417. * removed some notes/hints
  418. Revision 1.6 2002/05/18 13:34:06 peter
  419. * readded missing revisions
  420. Revision 1.5 2002/05/16 19:46:35 carl
  421. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  422. + try to fix temp allocation (still in ifdef)
  423. + generic constructor calls
  424. + start of tassembler / tmodulebase class cleanup
  425. Revision 1.3 2002/04/19 15:41:39 peter
  426. * better replacements that also allow $1 in the replacements without
  427. replacing that instance also
  428. Revision 1.2 2002/03/01 12:41:40 peter
  429. * fixed Message4()
  430. }