rtfpars.pp 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095
  1. Unit RTFPars;
  2. {
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Michael Van Canneyt, Member of the
  5. Free Pascal development team
  6. This unit implements a RTF Parser.
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  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.
  12. **********************************************************************}
  13. {$mode objfpc}
  14. interface
  15. Uses classes,sysutils;
  16. {$i rtfdata.inc}
  17. type Trtferrorhandler = Procedure (s : string) of object;
  18. { TRTFParser }
  19. TRTFParser = class(TObject)
  20. private
  21. FOnRTFError : TRTFerrorHandler;
  22. FfontList : PRTFFont;
  23. FcolorList : PRTFColor;
  24. FstyleList : PRTFStyle;
  25. FrtfClass,
  26. FrtfMajor,
  27. FrtfMinor,
  28. FrtfParam : Integer;
  29. rtfTextBuf : string [rtfBufSiz];
  30. rtfTextLen : Integer;
  31. pushedChar : Integer; { pushback char if read too far }
  32. pushedClass : Integer; { pushed token info for RTFUngetToken() }
  33. pushedMajor,
  34. pushedMinor,
  35. pushedParam : Integer;
  36. pushedTextBuf : String[rtfBufSiz];
  37. FStream : TStream;
  38. ccb : array [0..rtfMaxClass] of TRTFFuncPtr; { class callbacks }
  39. dcb : array [0..rtfMaxDestination] of TRTFFuncPtr; { destination callbacks }
  40. readHook : TRTFFUNCPTR;
  41. FTokenClass: Integer;
  42. Procedure Error (msg : String);
  43. Procedure LookupInit ;
  44. Procedure ReadFontTbl ;
  45. Procedure ReadColorTbl;
  46. Procedure ReadStyleSheet ;
  47. Procedure ReadInfoGroup ;
  48. Procedure ReadPictGroup ;
  49. Function CheckCM (Aclass, major: Integer) : Boolean;
  50. Function CheckCMM (Aclass, major, minor : Integer) : Boolean;
  51. Function CheckMM (major, minor : Integer) : Boolean;
  52. Procedure Real_RTFGetToken;
  53. Function GetChar : Integer;
  54. Procedure Lookup (S : String);
  55. Function GetFont (num : Integer) : PRTFFont;
  56. Function GetColor (num : Integer) : PRTFColor;
  57. Function GetStyle (num : Integer) : PRTFStyle;
  58. Procedure setClassCallback (Aclass : Integer; Acallback : TRTFFuncPtr);
  59. Function GetClassCallback (Aclass : Integer) : TRTFFuncPtr;
  60. Procedure SetDestinationCallback (ADestination : Integer; Acallback : TRTFFuncPtr);
  61. Function GetDestinationCallback (Adestination : Integer) : TRTFFuncPtr ;
  62. Procedure SetStream (Astream : TStream);
  63. public
  64. Constructor Create (AStream : TStream);
  65. Destructor Destroy; override;
  66. Procedure GetReadHook (Var q : TRTFFuncPtr);
  67. Function GetToken : Integer;
  68. Function PeekToken : Integer;
  69. Procedure ResetParser;
  70. Procedure RouteToken;
  71. Procedure SkipGroup;
  72. Procedure StartReading;
  73. Procedure SetReadHook (Hook : TRTFFuncPtr);
  74. Procedure UngetToken;
  75. Procedure SetToken (Aclass, major, minor, param : Integer; text : string);
  76. Procedure ExpandStyle (n : Integer);
  77. Function GetRtfBuf : String;
  78. { Properties }
  79. Property Colors [Index : Integer]: PRTFColor Read GetColor;
  80. Property ClassCallBacks [AClass : Integer]: TRTFFuncptr
  81. Read GetClassCallBack
  82. Write SetClassCallback;
  83. Property DestinationCallBacks [Adestination : Integer]: TRTFFuncptr
  84. Read GetdestinationCallBack
  85. Write SetdestinationCallback;
  86. Property Fonts [Index : Integer]: PRTFFont Read GetFont;
  87. Property OnRTFError : TRTFerrorHandler Read FOnRTFError Write FOnRTFError;
  88. Property rtfClass : Integer Read FrtfClass;
  89. Property rtfMajor : Integer Read FrtfMajor;
  90. Property rtfMinor : Integer Read FrtfMinor;
  91. Property rtfParam : Integer Read FrtfParam;
  92. Property Stream : TStream Read FStream Write SetStream;
  93. Property Styles [index : Integer] : PRTFStyle Read GetStyle;
  94. end;
  95. Implementation
  96. Const EOF = -255;
  97. { ---------------------------------------------------------------------
  98. Utility functions
  99. ---------------------------------------------------------------------}
  100. Function Hash (s : String) : Integer;
  101. var
  102. val,i : integer;
  103. Begin
  104. val:=0;
  105. for i:=1 to length(s) do
  106. val:=val+ord(s[i]);
  107. Hash:=val;
  108. End;
  109. Function isalpha (s : integer) : Boolean;
  110. begin
  111. result:= ( (s>=ord('A')) and (s<=ord('Z')))
  112. or (((s>=ord('a')) and ((s<=ord('z')) ))
  113. );
  114. end;
  115. Function isdigit (s : integer) : Boolean;
  116. begin
  117. result:= ( (s>=ord('0')) and (s<=ord('9')) )
  118. end;
  119. Function HexVal (c : Integer) : Integer;
  120. Begin
  121. if (c>=ord('A')) and (C<=ord('Z')) then inc (c,32);
  122. if c<ord ('A') then
  123. result:=(c - ord('0')) { '0'..'9' }
  124. else
  125. result:= (c - ord('a') + 10); { 'a'..'f' }
  126. End;
  127. { ---------------------------------------------------------------------
  128. Initialize the reader. This may be called multiple times,
  129. to read multiple files. The only thing not reset is the input
  130. stream; that must be done with RTFSetStream().
  131. ---------------------------------------------------------------------}
  132. Constructor TRTFParser.Create (Astream : TStream);
  133. Begin
  134. inherited create;
  135. { initialize lookup table }
  136. LookupInit ;
  137. Fstream := Astream;
  138. FfontList :=nil;
  139. FcolorList :=nil;
  140. FstyleList :=nil;
  141. onrtferror:=nil;
  142. ResetParser;
  143. end;
  144. Procedure TRTFParser.ResetParser;
  145. var
  146. cp : PRTFColor;
  147. fp : PRTFFont;
  148. sp : PRTFStyle;
  149. ep,eltlist : PRTFStyleElt;
  150. i : integer;
  151. begin
  152. for i:=0 to rtfMaxClass-1 do
  153. setClassCallback (i, Nil);
  154. for i:=0 to rtfMaxDestination-1 do
  155. SetDestinationCallback (i,nil);
  156. { install built-in destination readers }
  157. SetDestinationCallback (rtfFontTbl, @ReadFontTbl);
  158. SetDestinationCallback (rtfColorTbl, @ReadColorTbl);
  159. SetDestinationCallback (rtfStyleSheet, @ReadStyleSheet);
  160. SetDestinationCallback (rtfInfo, @ReadInfoGroup);
  161. SetDestinationCallback (rtfPict, @ReadPictGroup);
  162. SetReadHook (Nil);
  163. { dump old lists if necessary }
  164. while FfontList<>nil do
  165. Begin
  166. fp := FfontList^.rtfNextFont;
  167. dispose (FfontList);
  168. FfontList := fp;
  169. End;
  170. while FcolorList<>nil do
  171. Begin
  172. cp := FcolorList^.rtfNextColor;
  173. dispose (FcolorList);
  174. FcolorList := cp;
  175. End;
  176. while FstyleList<>nil do
  177. Begin
  178. sp := FstyleList^.rtfNextStyle;
  179. eltList := FstyleList^.rtfSSEList;
  180. while eltList<>nil do
  181. Begin
  182. ep:=eltList^.rtfNextSE;
  183. dispose(eltList);
  184. eltList:= ep;
  185. End;
  186. Dispose (FstyleList);
  187. FstyleList := sp;
  188. End;
  189. FrtfClass := -1;
  190. pushedClass := -1;
  191. pushedChar := EOF;
  192. { Reset the stream if it is assigned }
  193. if assigned (FStream) then
  194. FStream.seek(0,soFromBeginning);
  195. End;
  196. Destructor TRTFParser.Destroy;
  197. var
  198. cp : PRTFColor;
  199. fp : PRTFFont;
  200. sp : PRTFStyle;
  201. ep,eltlist : PRTFStyleElt;
  202. begin
  203. { Dump the lists. }
  204. while FfontList<>nil do
  205. Begin
  206. fp := FfontList^.rtfNextFont;
  207. dispose (FfontList);
  208. FfontList := fp;
  209. End;
  210. while FcolorList<>nil do
  211. Begin
  212. cp := FcolorList^.rtfNextColor;
  213. dispose (FcolorList);
  214. FcolorList := cp;
  215. End;
  216. while FstyleList<>nil do
  217. Begin
  218. sp := FstyleList^.rtfNextStyle;
  219. eltList := FstyleList^.rtfSSEList;
  220. while eltList<>nil do
  221. Begin
  222. ep:=eltList^.rtfNextSE;
  223. dispose(eltList);
  224. eltList:= ep;
  225. End;
  226. Dispose (FstyleList);
  227. FstyleList := sp;
  228. End;
  229. { Dump rest }
  230. inherited destroy;
  231. end;
  232. { ---------------------------------------------------------------------
  233. Callback table manipulation routines
  234. ---------------------------------------------------------------------}
  235. Procedure TRTFParser.SetClassCallback (Aclass : Integer; Acallback : TRTFFuncPtr);
  236. Begin
  237. if (aclass>=0) and (Aclass<rtfMaxClass) then
  238. ccb[Aclass]:= Acallback;
  239. End;
  240. Function TRTFParser.GetClassCallback (Aclass : Integer) : TRTFFuncPtr;
  241. Begin
  242. if (Aclass>=0) and (Aclass<rtfMaxClass) then
  243. GetClassCallback :=ccb[Aclass]
  244. else
  245. GetClassCallback:=nil;
  246. End;
  247. { ---------------------------------------------------------------------
  248. Install or return a writer callback for a destination type
  249. ---------------------------------------------------------------------}
  250. Procedure TRTFParser.SetDestinationCallback (ADestination : Integer; Acallback : TRTFFuncPtr);
  251. Begin
  252. if (Adestination>=0) and (Adestination<rtfMaxDestination) then
  253. dcb[ADestination] := Acallback;
  254. End;
  255. Function TRTFParser.GetDestinationCallback (Adestination : Integer) : TRTFFuncPtr ;
  256. Begin
  257. if (Adestination>=0) and (ADestination<rtfMaxDestination) then
  258. Result:=dcb[Adestination]
  259. Else
  260. Result:=nil;
  261. End;
  262. { ---------------------------------------------------------------------
  263. Token reading routines
  264. ---------------------------------------------------------------------}
  265. { Read the input stream, invoking the writer's callbacks where appropriate. }
  266. Procedure TRTFParser.StartReading;
  267. Begin
  268. { Reset stream. }
  269. FStream.Seek (0,soFromBeginning);
  270. { Start reading. }
  271. while (GetToken<>rtfEOF) do
  272. RouteToken;
  273. End;
  274. { Route a token. If it's a destination for which a reader is
  275. installed, process the destination internally, otherwise
  276. pass the token to the writer's class callback. }
  277. Procedure TRTFParser.RouteToken;
  278. Var
  279. p : TRTFFuncPtr;
  280. Begin
  281. if (rtfClass < 0) or (rtfClass>=rtfMaxClass) then
  282. Error ('No such class : '+rtfTextBuf)
  283. else
  284. begin
  285. if (CheckCM (rtfControl, rtfDestination)) then
  286. Begin
  287. { invoke destination-specific callback if there is one }
  288. p:=GetDestinationCallback (rtfMinor);
  289. if assigned(p) then
  290. Begin
  291. p;
  292. exit
  293. End;
  294. End;
  295. { invoke class callback if there is one }
  296. p:= GetClassCallback (rtfClass);
  297. if assigned(p) then
  298. p;
  299. end;
  300. End;
  301. { Skip to the end of the current group. When this returns,
  302. writers that maintain a state stack may want to call their
  303. state unstacker; global vars will still be set to the group's
  304. closing brace. }
  305. Procedure TRTFParser.SkipGroup;
  306. Var
  307. level : Integer;
  308. Begin
  309. level:= 1;
  310. while (GetToken<>rtfEOF) do
  311. if (rtfClass=rtfGroup) then
  312. Begin
  313. if (rtfMajor=rtfBeginGroup) then
  314. inc(level)
  315. else if (rtfMajor=rtfEndGroup) then
  316. Begin
  317. dec(level);
  318. if (level < 1) then
  319. exit; { end of initial group }
  320. End;
  321. End;
  322. End;
  323. { Read one token. Call the read hook if there is one. The
  324. token class is the return value. Returns rtfEOF when there
  325. are no more tokens. }
  326. Function TRTFParser.GetToken : Integer;
  327. var p : TRTFFuncPTR;
  328. Begin
  329. GetReadHook (p);
  330. while true do
  331. Begin
  332. Real_RTFGetToken;
  333. if (assigned(p)) then
  334. p; { give read hook a look at token }
  335. { Silently discard newlines and carriage returns. }
  336. if not ((rtfClass=rtfText) and ((rtfMajor=13) or (rtfmajor=10))) then
  337. break;
  338. End;
  339. result:=rtfClass;
  340. End;
  341. { ---------------------------------------------------------------------
  342. Install or return a token reader hook.
  343. ---------------------------------------------------------------------}
  344. Procedure TRTFParser.SetReadHook (Hook : TRTFFuncPtr);
  345. Begin
  346. readHook := Hook;
  347. End;
  348. Procedure TRTFParser.GetReadHook (Var q : TRTFFuncPtr);
  349. Begin
  350. Q:=readHook;
  351. End;
  352. Procedure TRTFParser.UngetToken;
  353. Begin
  354. if (pushedClass >= 0) then { there's already an ungotten token }
  355. Error ('cannot unget two tokens');
  356. if (rtfClass < 0) then
  357. Error ('no token to unget');
  358. pushedClass := rtfClass;
  359. pushedMajor := rtfMajor;
  360. pushedMinor := rtfMinor;
  361. pushedParam := rtfParam;
  362. rtfTextBuf := pushedTextBuf;
  363. End;
  364. Function TRTFParser.PeekToken : Integer;
  365. Begin
  366. Real_RTFGetToken;
  367. UngetToken;
  368. Result:=rtfClass;
  369. End;
  370. Procedure TRTFParser.Real_RTFGetToken;
  371. var sign,c,c2 : Integer;
  372. Begin
  373. { check for pushed token from RTFUngetToken() }
  374. if (pushedClass >= 0) then
  375. Begin
  376. FrtfClass := pushedClass;
  377. FrtfMajor := pushedMajor;
  378. FrtfMinor := pushedMinor;
  379. FrtfParam := pushedParam;
  380. rtfTextBuf := pushedTextBuf;
  381. rtfTextLen := length (rtfTextBuf);
  382. pushedClass := -1;
  383. exit;
  384. End;
  385. { initialize token vars }
  386. FrtfClass := rtfUnknown;
  387. FrtfParam := rtfNoParam;
  388. rtfTextBuf := '';
  389. rtfTextLen := 0;
  390. FTokenClass := rtfUnknown;
  391. { get first character, which may be a pushback from previous token }
  392. if (pushedChar <> EOF) then
  393. Begin
  394. c := pushedChar;
  395. rtfTextBuf:=rtfTextBuf+chr(c);
  396. inc(rtftextlen);
  397. pushedChar := EOF;
  398. End
  399. else
  400. begin
  401. c:=GetChar;
  402. if C=EOF then
  403. Begin
  404. FrtfClass := rtfEOF;
  405. exit;
  406. End;
  407. end;
  408. if c=ord('{') then
  409. Begin
  410. FrtfClass := rtfGroup;
  411. FrtfMajor := rtfBeginGroup;
  412. exit;
  413. End;
  414. if c=ord('}') then
  415. Begin
  416. FrtfClass := RTFGROUP;
  417. FrtfMajor := rtfEndGroup;
  418. exit;
  419. End;
  420. if c<>ord('\') then
  421. Begin
  422. { Two possibilities here:
  423. 1) ASCII 9, effectively like \tab control symbol
  424. 2) literal text char }
  425. if c=ord(#8) then { ASCII 9 }
  426. Begin
  427. FrtfClass := rtfControl;
  428. FrtfMajor := rtfSpecialChar;
  429. FrtfMinor := rtfTab;
  430. End
  431. else
  432. Begin
  433. FrtfClass := rtfText;
  434. FrtfMajor := c;
  435. End;
  436. exit;
  437. End;
  438. c:=getchar;
  439. if (c=EOF) then
  440. { early eof, whoops (class is rtfUnknown) }
  441. exit;
  442. if ( not isalpha (c)) then
  443. Begin
  444. { Three possibilities here:
  445. 1) hex encoded text char, e.g., \'d5, \'d3
  446. 2) special escaped text char, e.g., \, \;
  447. 3) control symbol, e.g., \_, \-, \|, \<10> }
  448. if c=ord('''') then { hex char }
  449. Begin
  450. c:=getchar;
  451. if (c<>EOF) then
  452. begin
  453. c2:=getchar;
  454. if (c2<>EOF) then
  455. Begin
  456. { should do isxdigit check! }
  457. FrtfClass := rtfText;
  458. FrtfMajor := HexVal (c) * 16 + HexVal (c2);
  459. exit;
  460. End;
  461. end;
  462. { early eof, whoops (class is rtfUnknown) }
  463. exit;
  464. End;
  465. if pos (chr(c),':{};\')<>0 then { escaped char }
  466. Begin
  467. FrtfClass := rtfText;
  468. FrtfMajor := c;
  469. exit;
  470. End;
  471. { control symbol }
  472. Lookup (rtfTextBuf); { sets class, major, minor }
  473. FTokenClass:=rtfControl;
  474. exit;
  475. End;
  476. { control word }
  477. while (isalpha (c)) do
  478. Begin
  479. c:=GetChar;
  480. if (c=EOF) then
  481. break;
  482. End;
  483. { At this point, the control word is all collected, so the
  484. major/minor numbers are determined before the parameter
  485. (if any) is scanned. There will be one too many characters
  486. in the buffer, though, so fix up before and restore after
  487. looking up. }
  488. if (c<>EOF) then
  489. delete(rtfTextBuf,length(rtfTextbuf),1);
  490. Lookup (rtfTextBuf); { sets class, major, minor }
  491. FTokenClass:=rtfControl;
  492. if (c <>EOF) then
  493. rtfTextBuf:=rtfTextBuf+chr(c);
  494. { Should be looking at first digit of parameter if there
  495. is one, unless it's negative. In that case, next char
  496. is '-', so need to gobble next char, and remember sign. }
  497. sign := 1;
  498. if c = ord('-') then
  499. Begin
  500. sign := -1;
  501. c := GetChar;
  502. End;
  503. if (c<>EOF) then
  504. if isdigit (c) then
  505. Begin
  506. FrtfParam := 0;
  507. while (isdigit (c)) do { gobble parameter }
  508. Begin
  509. FrtfParam := FrtfParam * 10 + c - ord('0');
  510. c:=GetChar;
  511. if (c=EOF) then
  512. break;
  513. End;
  514. FrtfParam:= sign*FrtfParam;
  515. End;
  516. { If control symbol delimiter was a blank, gobble it.
  517. Otherwise the character is first char of next token, so
  518. push it back for next call. In either case, delete the
  519. delimiter from the token buffer. }
  520. if (c<>EOF) then
  521. Begin
  522. if c<>ord (' ') then
  523. pushedChar := c;
  524. Delete (rtfTextBuf,rtfTextLen,1);
  525. Dec (rtfTextLen);
  526. End;
  527. End;
  528. Function TRTFParser.GetChar : Integer;
  529. var c : byte;
  530. Begin
  531. if FStream.read(c,1)<>0 then
  532. begin
  533. if (c and 128)=128 then c:=ord('?');
  534. Result:=c;
  535. rtfTextBuf:=rtfTextBuf+chr(c);
  536. inc(rtfTextLen);
  537. end
  538. else
  539. Result:=EOF;
  540. End;
  541. { Synthesize a token by setting the global variables to the
  542. values supplied. Typically this is followed with a call
  543. to RTFRouteToken().
  544. If param is non-negative, it becomes part of the token text. }
  545. Procedure TRTFParser.SetToken (Aclass, major, minor, param : Integer; text : string);
  546. Begin
  547. FrtfClass := Aclass;
  548. FrtfMajor := major;
  549. FrtfMinor := minor;
  550. FrtfParam := param;
  551. if (param=rtfNoParam) then
  552. rtfTextBuf:=text
  553. else
  554. rtfTextBuf:=text+IntTostr(param);
  555. rtfTextLen:=length(rtfTextBuf);
  556. End;
  557. { ---------------------------------------------------------------------
  558. Special destination readers. They gobble the destination so the
  559. writer doesn't have to deal with them. That's wrong for any
  560. translator that wants to process any of these itself. In that
  561. case, these readers should be overridden by installing a different
  562. destination callback.
  563. NOTE: The last token read by each of these reader will be the
  564. destination's terminating '', which will then be the current token.
  565. That 'End;' token is passed to RTFRouteToken() - the writer has already
  566. seen the 'Begin' that began the destination group, and may have pushed a
  567. state; it also needs to know at the end of the group that a state
  568. should be popped.
  569. It's important that rtfdata.inc and the control token lookup table list
  570. as many symbols as possible, because these readers unfortunately
  571. make strict assumptions about the input they expect, and a token
  572. of class rtfUnknown will throw them off easily.
  573. ----------------------------------------------------------------------}
  574. { Read Begin \fonttbl ... End; destination. Old font tables don't have
  575. braces around each table entry; try to adjust for that.}
  576. Procedure TRTFParser.ReadFontTbl;
  577. var
  578. fp : PRTFFont;
  579. bp : string[rtfbufsiz];
  580. old : Integer;
  581. Begin
  582. old := -1;
  583. While true do
  584. Begin
  585. GetToken;
  586. if CheckCM (rtfGroup, rtfEndGroup) then
  587. break;
  588. if (old < 0) then { first entry - determine tbl type }
  589. Begin
  590. if CheckCMM (rtfControl, rtfCharAttr, rtfFontNum) then
  591. old:=1 { no brace }
  592. else if CheckCM (rtfGroup, rtfBeginGroup) then
  593. old:= 0 { brace }
  594. else { can't tell! }
  595. Error ('FTErr - Cannot determine format')
  596. End;
  597. if (old=0) then { need to find "Begin" here }
  598. Begin
  599. if not CheckCM (rtfGroup, rtfBeginGroup) then
  600. Error ('FTErr - missing {');
  601. GetToken; { yes, skip to next token }
  602. End;
  603. new(fp);
  604. if (fp=nil) then
  605. Error ('FTErr - cannot allocate font entry');
  606. fp^.rtfNextFont:= FfontList;
  607. FfontList:=fp;
  608. if not CheckCMM (rtfControl, rtfCharAttr, rtfFontNum) then
  609. Error ('FTErr - missing font number');
  610. fp^.rtfFNum := rtfParam;
  611. { Read optionalcommands. Recognize only fontfamily}
  612. GetToken;
  613. if not CheckCM (rtfControl, rtfFontFamily) then
  614. error ('FTErr - missing font family ');
  615. fp^.rtfFFamily := rtfMinor;
  616. { Read optional commands/groups. Recognize none at this point..}
  617. GetToken;
  618. while (rtfclass=rtfcontrol) or ((rtfclass=rtfgroup) or (rtfclass=rtfunknown)) do
  619. begin
  620. if rtfclass=rtfgroup then SkipGroup;
  621. GetToken
  622. end;
  623. { Read font name }
  624. bp:='';
  625. while (rtfclass=rtfText) do
  626. Begin
  627. if rtfMajor=ord(';') then
  628. break;
  629. bp:=bp+chr(rtfMajor);
  630. GetToken
  631. End;
  632. if bp='' then
  633. Error ('FTErr - missing font name');
  634. fp^.rtffname:=bp;
  635. { Read alternate font}
  636. if rtfclass=rtfgroup then
  637. begin
  638. SkipGroup;
  639. if Not rtfMajor=ord(';') then
  640. Error('Alternate font badly terminated');
  641. GetToken;
  642. end;
  643. if (old=0) then { need to see "End;" here }
  644. Begin
  645. GetToken;
  646. if not CheckCM (rtfGroup, rtfEndGroup) then
  647. Error ('FTErr - missing }');
  648. End;
  649. End;
  650. RouteToken; { feed "End;" back to router }
  651. End;
  652. { The color table entries have color values of -1 if
  653. the default color should be used for the entry (only
  654. a semi-colon is given in the definition, no color values).
  655. There will be a problem if a partial entry (1 or 2 but
  656. not 3 color values) is given. The possibility is ignored
  657. here. }
  658. Procedure TRTFParser.ReadColorTbl;
  659. var
  660. cp : PRTFColor;
  661. cnum : Integer;
  662. Begin
  663. cnum:=0;
  664. While true do
  665. Begin
  666. GetToken;
  667. if CheckCM (rtfGroup, rtfEndGroup) then
  668. break;
  669. new(cp);
  670. if (cp=nil) then
  671. Error ('CTErr - cannot allocate color entry');
  672. cp^.rtfCNum :=cnum;
  673. cp^.rtfCRed :=-1;
  674. cp^.rtfCGreen:=-1;
  675. cp^.rtfCBlue :=-1;
  676. cp^.rtfNextColor := FColorList;
  677. inc(cnum);
  678. FcolorList:=cp;
  679. while true do
  680. Begin
  681. if not CheckCM (rtfControl, rtfColorName) then
  682. break;
  683. case rtfMinor of
  684. rtfRed: cp^.rtfCRed :=rtfParam;
  685. rtfGreen: cp^.rtfCGreen :=rtfParam;
  686. rtfBlue: cp^.rtfCBlue :=rtfParam;
  687. End;
  688. GetToken;
  689. End;
  690. if not CheckCM (rtfText, ord(';')) then
  691. Error ('CTErr - malformed entry');
  692. End;
  693. RouteToken; { feed "End;" back to router }
  694. End;
  695. { The "Normal" style definition doesn't contain any style number
  696. (why?), all others do. Normal style is given style 0. }
  697. Procedure TRTFParser.ReadStyleSheet;
  698. var
  699. sp : PRTFStyle;
  700. sep,sepLast : PRTFStyleElt;
  701. bp : string[rtfBufSiz];
  702. I : Integer;
  703. Begin
  704. While true do
  705. Begin
  706. GetToken;
  707. if CheckCM (rtfGroup, rtfEndGroup) then
  708. break;
  709. new (sp);
  710. if sp=nil then
  711. Error ('SSErr - cannot allocate stylesheet entry');
  712. sp^.rtfSNum := -1;
  713. sp^.rtfSBasedOn := rtfBasedOnNone;
  714. sp^.rtfSNextPar := -1;
  715. sp^.rtfSSEList := nil;
  716. sepLast:=nil;
  717. sp^.rtfNextStyle := FstyleList;
  718. sp^.rtfExpanding := 0;
  719. FstyleList := sp;
  720. if not CheckCM (rtfGroup, rtfBeginGroup) then
  721. Error ('SSErr - missing {');
  722. I:=0;
  723. GetToken;
  724. while (fRTFClass=rtfControl) or (FTokenClass=rtfControl) or (FRTFClass=rtfGroup) do
  725. Begin
  726. If CheckCM(rtfGroup, rtfBeginGroup) then
  727. SkipGroup
  728. else if rtfClass<>rtfUnknown then
  729. begin
  730. if (CheckMM (rtfParAttr, rtfStyleNum)) then
  731. sp^.rtfSNum:=rtfParam
  732. else if (CheckMM (rtfStyleAttr, rtfBasedOn)) then
  733. sp^.rtfSBasedOn:=rtfParam
  734. else if (CheckMM (rtfStyleAttr, rtfNext)) then
  735. sp^.rtfSNextPar:=rtfParam
  736. else
  737. begin
  738. new(sep);
  739. if sep=nil then
  740. Error ('SSErr - cannot allocate style element');
  741. sep^.rtfSEClass:=rtfClass;
  742. sep^.rtfSEMajor:=rtfMajor;
  743. sep^.rtfSEMinor:=rtfMinor;
  744. sep^.rtfSEParam:=rtfParam;
  745. sep^.rtfSEText:=rtfTextBuf;
  746. if sepLast=nil then
  747. sp^.rtfSSEList:=sep { first element }
  748. else { add to end }
  749. sepLast^.rtfNextSE:=sep;
  750. sep^.rtfNextSE:=nil;
  751. sepLast:=sep;
  752. end;
  753. end;
  754. GetToken;
  755. End;
  756. if sp^.rtfSNextPar=-1 then { \snext not given }
  757. sp^.rtfSNextPar:=sp^.rtfSNum; { next is itself }
  758. if rtfClass<>rtfText then
  759. Error ('SSErr - missing style name');
  760. Bp:='';
  761. while rtfClass=rtfText do
  762. Begin
  763. if rtfMajor=ord(';') then
  764. Begin
  765. GetToken;
  766. break;
  767. End;
  768. bp:=bp+chr(rtfMajor);
  769. GetToken;
  770. End;
  771. if (sp^.rtfSNum < 0) then { no style number was specified }
  772. Begin { (only legal for Normal style) }
  773. if bp<>'Normal' then
  774. Error ('SSErr - missing style number');
  775. sp^.rtfSNum:=0;
  776. End;
  777. sp^.rtfSName:=bp;
  778. if not CheckCM (rtfGroup, rtfEndGroup) then
  779. Error ('SSErr - missing }');
  780. End;
  781. RouteToken; { feed "End;" back to router }
  782. End;
  783. Procedure TRTFParser.ReadInfoGroup;
  784. Begin
  785. SkipGroup ;
  786. RouteToken ; { feed "End;" back to router }
  787. End;
  788. Procedure TRTFParser.ReadPictGroup;
  789. Begin
  790. SkipGroup ;
  791. RouteToken ; { feed "End;" back to router }
  792. End;
  793. { ----------------------------------------------------------------------
  794. Routines to return pieces of stylesheet, or font or color tables
  795. ----------------------------------------------------------------------}
  796. Function TRTFParser.GetStyle (num : Integer) : PRTFStyle;
  797. var
  798. s : PRTFSTyle;
  799. Begin
  800. s:=Fstylelist;
  801. if num<>1 then
  802. while s<>nil do
  803. Begin
  804. if (s^.rtfSNum=num) then break;
  805. s:=s^.rtfNextStyle;
  806. End;
  807. result:=s; { NULL if not found }
  808. End;
  809. Function TRTFParser.GetFont (num : Integer) : PRTFFont;
  810. Var
  811. f :PRTFFont;
  812. Begin
  813. f:=FfontList;
  814. if num<>-1 then
  815. while f<>nil do
  816. Begin
  817. if f^.rtfFNum=num then break;
  818. f:=f^.rtfNextFont;
  819. End;
  820. result:=f; { NULL if not found }
  821. End;
  822. Function TRTFParser.GetColor (num : Integer) : PRTFColor;
  823. var
  824. c : PRTFColor;
  825. Begin
  826. c:=Fcolorlist;
  827. if (num<>-1) then
  828. while c<>nil do
  829. Begin
  830. if c^.rtfCNum=num then break;
  831. c:=c^.rtfNextColor;
  832. End;
  833. Result:=c; { NULL if not found }
  834. End;
  835. { ---------------------------------------------------------------------
  836. Expand style n, if there is such a style.
  837. ---------------------------------------------------------------------}
  838. Procedure TRTFParser.ExpandStyle (n : Integer);
  839. var
  840. s : PRTFStyle;
  841. se : PRTFStyleElt;
  842. Begin
  843. if n=-1 then exit;
  844. s:=GetStyle (n);
  845. if s=nil then exit;
  846. if (s^.rtfExpanding<>0) then
  847. Error ('Style expansion loop, style '+inttostr(n));
  848. s^.rtfExpanding:=1; { set expansion flag for loop detection }
  849. {
  850. Expand "based-on" style. This is done by synthesizing
  851. the token that the writer needs to see in order to trigger
  852. another style expansion, and feeding to token back through
  853. the router so the writer sees it.
  854. }
  855. SetToken (rtfControl, rtfParAttr, rtfStyleNum, s^.rtfSBasedOn, '\s');
  856. RouteToken;
  857. {
  858. Now route the tokens unique to this style. RTFSetToken()
  859. isn't used because it would add the param value to the end
  860. of the token text, which already has it in.
  861. }
  862. se:=s^.rtfSSEList;
  863. while se<>nil do
  864. Begin
  865. FrtfClass:=se^.rtfSEClass;
  866. FrtfMajor:=se^.rtfSEMajor;
  867. FrtfMinor:=se^.rtfSEMinor;
  868. FrtfParam:=se^.rtfSEParam;
  869. rtfTextBuf:=se^.rtfSEText;
  870. rtfTextLen:=length (rtfTextBuf);
  871. RouteToken;
  872. se:=se^.rtfNextSE
  873. End;
  874. s^.rtfExpanding:=0; { done - clear expansion flag }
  875. End;
  876. function TRTFParser.GetRtfBuf: String;
  877. begin
  878. Result:=rtfTextBuf;
  879. end;
  880. { ---------------------------------------------------------------------
  881. Initialize lookup table hash values.
  882. Only need to do this the first time it's called.
  883. ---------------------------------------------------------------------}
  884. Procedure TRTFParser.LookupInit;
  885. var count : Integer;
  886. Begin
  887. count:=0;
  888. while rtfkey[count].rtfKStr<>'' do
  889. begin
  890. rtfkey[count].rtfKHash:=Hash (rtfkey[count].rtfKStr);
  891. inc(count)
  892. End;
  893. End;
  894. { ---------------------------------------------------------------------
  895. Determine major and minor number of control token. If it's
  896. not found, the class turns into rtfUnknown.
  897. ---------------------------------------------------------------------}
  898. Procedure TRTFParser.Lookup (S : String);
  899. var
  900. thehash,rp : Integer;
  901. Begin
  902. delete(s,1,1); { skip over the leading \ character }
  903. thehash:=Hash (s);
  904. rp:=0;
  905. while rtfkey[rp].rtfKstr<>'' do
  906. Begin
  907. if (thehash=rtfkey[rp].rtfKHash) and (s=rtfkey[rp].rtfKStr) then
  908. Begin
  909. FrtfClass:=rtfControl;
  910. FrtfMajor:=rtfkey[rp].rtfKMajor;
  911. FrtfMinor:=rtfkey[rp].rtfKMinor;
  912. exit;
  913. End;
  914. inc(rp);
  915. End;
  916. FrtfClass:=rtfUnknown;
  917. End;
  918. Procedure TRTFParser.Error (msg : String);
  919. { Call errorhandler }
  920. begin
  921. if assigned(onrtferror) then onrtferror(msg);
  922. end;
  923. { ---------------------------------------------------------------------
  924. Token comparison routines
  925. ---------------------------------------------------------------------}
  926. Function TRTFParser.CheckCM (Aclass, major: Integer) : Boolean;
  927. Begin
  928. Result:=(rtfClass=Aclass) and (rtfMajor=major);
  929. End;
  930. Function TRTFParser.CheckCMM (Aclass, major, minor : Integer) : Boolean;
  931. Begin
  932. Result:=(rtfClass=Aclass) and ((rtfMajor=major) and (rtfMinor=minor));
  933. End;
  934. Function TRTFParser.CheckMM (major, minor : Integer) : Boolean;
  935. Begin
  936. Result:=(rtfMajor=major) and (rtfMinor=minor);
  937. End;
  938. Procedure TRTFParser.SetStream (Astream : TStream);
  939. begin
  940. FStream:=Astream;
  941. end;
  942. end.