cobjects.pas 27 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 by Florian Klaempfl
  4. This module provides some basic objects
  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. {$ifdef tp}
  19. {$E+,N+,D+,F+}
  20. {$endif}
  21. {$I-}
  22. {$R-}{ necessary for crc calculation }
  23. unit cobjects;
  24. interface
  25. uses
  26. strings
  27. {$ifndef linux}
  28. ,dos
  29. {$else}
  30. ,linux
  31. {$endif}
  32. ;
  33. type
  34. pstring = ^string;
  35. { some help data types }
  36. pstringitem = ^tstringitem;
  37. tstringitem = record
  38. data : pstring;
  39. next : pstringitem;
  40. end;
  41. plinkedlist_item = ^tlinkedlist_item;
  42. tlinkedlist_item = object
  43. next,last : plinkedlist_item;
  44. { does nothing }
  45. constructor init;
  46. destructor done;virtual;
  47. end;
  48. pstring_item = ^tstring_item;
  49. tstring_item = object(tlinkedlist_item)
  50. str : pstring;
  51. constructor init(const s : string);
  52. destructor done;virtual;
  53. end;
  54. plinkedlist = ^tlinkedlist;
  55. { this implements a double linked list }
  56. tlinkedlist = object
  57. first,last : plinkedlist_item;
  58. constructor init;
  59. destructor done;
  60. { disposes the items of the list }
  61. procedure clear;
  62. { concats a new item at the end }
  63. procedure concat(p : plinkedlist_item);
  64. { inserts a new item at the begin }
  65. procedure insert(p : plinkedlist_item);
  66. { inserts another list at the begin and make this list empty }
  67. procedure insertlist(p : plinkedlist);
  68. { concats another list at the end and make this list empty }
  69. procedure concatlist(p : plinkedlist);
  70. { removes p from the list (p isn't disposed) }
  71. { it's not tested if p is in the list ! }
  72. procedure remove(p : plinkedlist_item);
  73. end;
  74. { String Queue}
  75. PStringQueue=^TStringQueue;
  76. TStringQueue=object
  77. first,last : PStringItem;
  78. constructor Init;
  79. destructor Done;
  80. function Empty:boolean;
  81. function Get:string;
  82. procedure Insert(const s:string);
  83. procedure Concat(const s:string);
  84. procedure Clear;
  85. end;
  86. { string container }
  87. pstringcontainer = ^tstringcontainer;
  88. tstringcontainer = object
  89. root,last : pstringitem;
  90. { if this is set to true, doubles are allowed }
  91. { true is default }
  92. doubles : boolean;
  93. constructor init;
  94. destructor done;
  95. { true is the container empty }
  96. function empty:boolean;
  97. { inserts a string }
  98. procedure insert(const s : string);
  99. { gets a string }
  100. function get : string;
  101. { deletes all strings }
  102. procedure clear;
  103. end;
  104. pbufferedfile = ^tbufferedfile;
  105. { this is implemented to allow buffered binary I/O }
  106. tbufferedfile = object
  107. f : file;
  108. buf : pchar;
  109. bufsize,buflast,bufpos : longint;
  110. { 0 closed, 1 input, 2 output }
  111. iomode : byte;
  112. { true, if the compile should change the endian of the output }
  113. change_endian : boolean;
  114. { calcules a crc for the file, }
  115. { but it's assumed, that there no seek while do_crc is true }
  116. do_crc : boolean;
  117. crc : longint;
  118. { inits a buffer with the size bufsize which is assigned to }
  119. { the file filename }
  120. constructor init(const filename : string;_bufsize : longint);
  121. { closes the file, if needed, and releases the memory }
  122. destructor done;virtual;
  123. { opens the file for input, other accesses are rejected }
  124. procedure reset;
  125. { opens the file for output, other accesses are rejected }
  126. procedure rewrite;
  127. { reads or writes the buffer from or to disk }
  128. procedure flush;
  129. { writes a string to the file }
  130. { the string is written without a length byte }
  131. procedure write_string(const s : string);
  132. { writes a zero terminated string }
  133. procedure write_pchar(p : pchar);
  134. { write specific data types, takes care of }
  135. { byte order }
  136. procedure write_byte(b : byte);
  137. procedure write_word(w : word);
  138. procedure write_long(l : longint);
  139. procedure write_double(d : double);
  140. { writes any data }
  141. procedure write_data(var data;count : longint);
  142. { reads any data }
  143. procedure read_data(var data;bytes : longint;var count : longint);
  144. { closes the file and releases the buffer }
  145. procedure close;
  146. { goto the given position }
  147. procedure seek(l : longint);
  148. { installes an user defined buffer }
  149. { and releases the old one, but be }
  150. { careful, if the old buffer contains }
  151. { data, this data is lost }
  152. procedure setbuf(p : pchar;s : longint);
  153. { reads the file time stamp of the file, }
  154. { the file must be opened }
  155. function getftime : longint;
  156. { returns filesize }
  157. function getsize : longint;
  158. { returns the path }
  159. function getpath : string;
  160. { resets the crc }
  161. procedure clear_crc;
  162. { returns the crc }
  163. function getcrc : longint;
  164. end;
  165. { releases the string p and assignes nil to p }
  166. { if p=nil then freemem isn't called }
  167. procedure stringdispose(var p : pstring);
  168. { allocates mem for a copy of s, copies s to this mem and returns }
  169. { a pointer to this mem }
  170. function stringdup(const s : string) : pstring;
  171. { allocates memory for s and copies s as zero terminated string
  172. to that mem and returns a pointer to that mem }
  173. function strpnew(const s : string) : pchar;
  174. { makes a char lowercase, with spanish, french and german char set }
  175. function lowercase(c : char) : char;
  176. { makes zero terminated string to a pascal string }
  177. { the data in p is modified and p is returned }
  178. function pchar2pstring(p : pchar) : pstring;
  179. { ambivalent to pchar2pstring }
  180. function pstring2pchar(p : pstring) : pchar;
  181. implementation
  182. function pchar2pstring(p : pchar) : pstring;
  183. var
  184. w : word;
  185. i : longint;
  186. begin
  187. w:=strlen(p);
  188. for i:=w-1 downto 0 do
  189. p[i+1]:=p[i];
  190. p[0]:=chr(w);
  191. pchar2pstring:=pstring(p);
  192. end;
  193. function pstring2pchar(p : pstring) : pchar;
  194. var
  195. w : word;
  196. i : longint;
  197. begin
  198. w:=ord(p^[0]);
  199. for i:=1 to w do
  200. p^[i-1]:=p^[i];
  201. p^[w]:=#0;
  202. pstring2pchar:=pchar(p);
  203. end;
  204. function lowercase(c : char) : char;
  205. begin
  206. case c of
  207. #65..#90 : c := chr(ord (c) + 32);
  208. #154 : c:=#129; { german }
  209. #142 : c:=#132; { german }
  210. #153 : c:=#148; { german }
  211. #144 : c:=#130; { french }
  212. #128 : c:=#135; { french }
  213. #143 : c:=#134; { swedish/norge (?) }
  214. #165 : c:=#164; { spanish }
  215. #228 : c:=#229; { greek }
  216. #226 : c:=#231; { greek }
  217. #232 : c:=#227; { greek }
  218. end;
  219. lowercase := c;
  220. end;
  221. function strpnew(const s : string) : pchar;
  222. var
  223. p : pchar;
  224. begin
  225. getmem(p,length(s)+1);
  226. strpcopy(p,s);
  227. strpnew:=p;
  228. end;
  229. procedure stringdispose(var p : pstring);
  230. begin
  231. if assigned(p) then
  232. freemem(p,length(p^)+1);
  233. p:=nil;
  234. end;
  235. function stringdup(const s : string) : pstring;
  236. var
  237. p : pstring;
  238. begin
  239. getmem(p,length(s)+1);
  240. p^:=s;
  241. stringdup:=p;
  242. end;
  243. {****************************************************************************
  244. TStringQueue
  245. ****************************************************************************}
  246. constructor TStringQueue.Init;
  247. begin
  248. first:=nil;
  249. end;
  250. function TStringQueue.Empty:boolean;
  251. begin
  252. Empty:=(first=nil);
  253. end;
  254. function TStringQueue.Get:string;
  255. var
  256. hp : pstringitem;
  257. begin
  258. if first=nil then
  259. begin
  260. Get:='';
  261. exit;
  262. end;
  263. Get:=first^.data^;
  264. stringdispose(first^.data);
  265. hp:=first;
  266. first:=first^.next;
  267. dispose(hp);
  268. end;
  269. procedure TStringQueue.Insert(const s:string);
  270. var
  271. hp : pstringitem;
  272. begin
  273. new(hp);
  274. hp^.next:=first;
  275. hp^.data:=stringdup(s);
  276. first:=hp;
  277. if last=nil then
  278. last:=hp;
  279. end;
  280. procedure TStringQueue.Concat(const s:string);
  281. var
  282. hp : pstringitem;
  283. begin
  284. new(hp);
  285. hp^.next:=nil;
  286. hp^.data:=stringdup(s);
  287. if first=nil then
  288. first:=hp
  289. else
  290. last^.next:=hp;
  291. last:=hp;
  292. end;
  293. procedure TStringQueue.Clear;
  294. var
  295. hp : pstringitem;
  296. begin
  297. while (first<>nil) do
  298. begin
  299. hp:=first;
  300. stringdispose(first^.data);
  301. first:=first^.next;
  302. dispose(hp);
  303. end;
  304. end;
  305. destructor TStringQueue.Done;
  306. begin
  307. Clear;
  308. end;
  309. {****************************************************************************
  310. TSTRINGCONTAINER
  311. ****************************************************************************}
  312. constructor tstringcontainer.init;
  313. begin
  314. root:=nil;
  315. last:=nil;
  316. doubles:=true;
  317. end;
  318. destructor tstringcontainer.done;
  319. begin
  320. clear;
  321. end;
  322. function tstringcontainer.empty:boolean;
  323. begin
  324. empty:=(root=nil);
  325. end;
  326. procedure tstringcontainer.insert(const s : string);
  327. var
  328. hp : pstringitem;
  329. begin
  330. if not(doubles) then
  331. begin
  332. hp:=root;
  333. while assigned(hp) do
  334. begin
  335. if hp^.data^=s then exit;
  336. hp:=hp^.next;
  337. end;
  338. end;
  339. new(hp);
  340. hp^.next:=nil;
  341. hp^.data:=stringdup(s);
  342. if root=nil then root:=hp
  343. else last^.next:=hp;
  344. last:=hp;
  345. end;
  346. procedure tstringcontainer.clear;
  347. var
  348. hp : pstringitem;
  349. begin
  350. hp:=root;
  351. while assigned(hp) do
  352. begin
  353. stringdispose(hp^.data);
  354. root:=hp^.next;
  355. dispose(hp);
  356. hp:=root;
  357. end;
  358. last:=nil;
  359. root:=nil;
  360. end;
  361. function tstringcontainer.get : string;
  362. var
  363. hp : pstringitem;
  364. begin
  365. if root=nil then
  366. get:=''
  367. else
  368. begin
  369. get:=root^.data^;
  370. hp:=root;
  371. root:=root^.next;
  372. stringdispose(hp^.data);
  373. dispose(hp);
  374. end;
  375. end;
  376. {****************************************************************************
  377. TLINKEDLIST_ITEM
  378. ****************************************************************************}
  379. constructor tlinkedlist_item.init;
  380. begin
  381. last:=nil;
  382. next:=nil;
  383. end;
  384. destructor tlinkedlist_item.done;
  385. begin
  386. end;
  387. {****************************************************************************
  388. TSTRING_ITEM
  389. ****************************************************************************}
  390. constructor tstring_item.init(const s : string);
  391. begin
  392. str:=stringdup(s);
  393. end;
  394. destructor tstring_item.done;
  395. begin
  396. stringdispose(str);
  397. inherited done;
  398. end;
  399. {****************************************************************************
  400. TLINKEDLIST
  401. ****************************************************************************}
  402. constructor tlinkedlist.init;
  403. begin
  404. first:=nil;
  405. last:=nil;
  406. end;
  407. destructor tlinkedlist.done;
  408. begin
  409. clear;
  410. end;
  411. procedure tlinkedlist.clear;
  412. var
  413. hp : plinkedlist_item;
  414. begin
  415. hp:=first;
  416. while assigned(hp) do
  417. begin
  418. first:=hp^.next;
  419. dispose(hp,done);
  420. hp:=first;
  421. end;
  422. end;
  423. procedure tlinkedlist.insertlist(p : plinkedlist);
  424. begin
  425. { empty list ? }
  426. if not(assigned(p^.first)) then
  427. exit;
  428. p^.last^.next:=first;
  429. { we have a double linked list }
  430. if assigned(first) then
  431. first^.last:=p^.last;
  432. first:=p^.first;
  433. if not(assigned(last)) then
  434. last:=p^.last;
  435. { p becomes empty }
  436. p^.first:=nil;
  437. p^.last:=nil;
  438. end;
  439. procedure tlinkedlist.concat(p : plinkedlist_item);
  440. begin
  441. p^.last:=nil;
  442. p^.next:=nil;
  443. if not(assigned(first)) then
  444. first:=p
  445. else
  446. begin
  447. last^.next:=p;
  448. p^.last:=last;
  449. end;
  450. last:=p;
  451. end;
  452. procedure tlinkedlist.insert(p : plinkedlist_item);
  453. begin
  454. p^.last:=nil;
  455. p^.next:=nil;
  456. if not(assigned(first)) then
  457. last:=p
  458. else
  459. begin
  460. first^.last:=p;
  461. p^.next:=first;
  462. first:=p;
  463. end;
  464. first:=p;
  465. end;
  466. procedure tlinkedlist.remove(p : plinkedlist_item);
  467. begin
  468. if not(assigned(p)) then
  469. exit;
  470. if (first=p) and (last=p) then
  471. begin
  472. first:=nil;
  473. last:=nil;
  474. end
  475. else if first=p then
  476. begin
  477. first:=p^.next;
  478. if assigned(first) then
  479. first^.last:=nil;
  480. end
  481. else if last=p then
  482. begin
  483. last:=last^.last;
  484. if assigned(last) then
  485. last^.next:=nil;
  486. end
  487. else
  488. begin
  489. p^.last^.next:=p^.next;
  490. p^.next^.last:=p^.last;
  491. end;
  492. p^.next:=nil;
  493. p^.last:=nil;
  494. end;
  495. procedure tlinkedlist.concatlist(p : plinkedlist);
  496. begin
  497. if not(assigned(p^.first)) then
  498. exit;
  499. if not(assigned(first)) then
  500. first:=p^.first
  501. else
  502. begin
  503. last^.next:=p^.first;
  504. p^.first^.last:=last;
  505. end;
  506. last:=p^.last;
  507. { make p empty }
  508. p^.last:=nil;
  509. p^.first:=nil;
  510. end;
  511. {****************************************************************************
  512. TBUFFEREDFILE
  513. ****************************************************************************}
  514. Const
  515. crcseed = $ffffffff;
  516. crctable : array[0..255] of longint = (
  517. $00000000,$77073096,$ee0e612c,$990951ba,$076dc419,$706af48f,
  518. $e963a535,$9e6495a3,$0edb8832,$79dcb8a4,$e0d5e91e,$97d2d988,
  519. $09b64c2b,$7eb17cbd,$e7b82d07,$90bf1d91,$1db71064,$6ab020f2,
  520. $f3b97148,$84be41de,$1adad47d,$6ddde4eb,$f4d4b551,$83d385c7,
  521. $136c9856,$646ba8c0,$fd62f97a,$8a65c9ec,$14015c4f,$63066cd9,
  522. $fa0f3d63,$8d080df5,$3b6e20c8,$4c69105e,$d56041e4,$a2677172,
  523. $3c03e4d1,$4b04d447,$d20d85fd,$a50ab56b,$35b5a8fa,$42b2986c,
  524. $dbbbc9d6,$acbcf940,$32d86ce3,$45df5c75,$dcd60dcf,$abd13d59,
  525. $26d930ac,$51de003a,$c8d75180,$bfd06116,$21b4f4b5,$56b3c423,
  526. $cfba9599,$b8bda50f,$2802b89e,$5f058808,$c60cd9b2,$b10be924,
  527. $2f6f7c87,$58684c11,$c1611dab,$b6662d3d,$76dc4190,$01db7106,
  528. $98d220bc,$efd5102a,$71b18589,$06b6b51f,$9fbfe4a5,$e8b8d433,
  529. $7807c9a2,$0f00f934,$9609a88e,$e10e9818,$7f6a0dbb,$086d3d2d,
  530. $91646c97,$e6635c01,$6b6b51f4,$1c6c6162,$856530d8,$f262004e,
  531. $6c0695ed,$1b01a57b,$8208f4c1,$f50fc457,$65b0d9c6,$12b7e950,
  532. $8bbeb8ea,$fcb9887c,$62dd1ddf,$15da2d49,$8cd37cf3,$fbd44c65,
  533. $4db26158,$3ab551ce,$a3bc0074,$d4bb30e2,$4adfa541,$3dd895d7,
  534. $a4d1c46d,$d3d6f4fb,$4369e96a,$346ed9fc,$ad678846,$da60b8d0,
  535. $44042d73,$33031de5,$aa0a4c5f,$dd0d7cc9,$5005713c,$270241aa,
  536. $be0b1010,$c90c2086,$5768b525,$206f85b3,$b966d409,$ce61e49f,
  537. $5edef90e,$29d9c998,$b0d09822,$c7d7a8b4,$59b33d17,$2eb40d81,
  538. $b7bd5c3b,$c0ba6cad,$edb88320,$9abfb3b6,$03b6e20c,$74b1d29a,
  539. $ead54739,$9dd277af,$04db2615,$73dc1683,$e3630b12,$94643b84,
  540. $0d6d6a3e,$7a6a5aa8,$e40ecf0b,$9309ff9d,$0a00ae27,$7d079eb1,
  541. $f00f9344,$8708a3d2,$1e01f268,$6906c2fe,$f762575d,$806567cb,
  542. $196c3671,$6e6b06e7,$fed41b76,$89d32be0,$10da7a5a,$67dd4acc,
  543. $f9b9df6f,$8ebeeff9,$17b7be43,$60b08ed5,$d6d6a3e8,$a1d1937e,
  544. $38d8c2c4,$4fdff252,$d1bb67f1,$a6bc5767,$3fb506dd,$48b2364b,
  545. $d80d2bda,$af0a1b4c,$36034af6,$41047a60,$df60efc3,$a867df55,
  546. $316e8eef,$4669be79,$cb61b38c,$bc66831a,$256fd2a0,$5268e236,
  547. $cc0c7795,$bb0b4703,$220216b9,$5505262f,$c5ba3bbe,$b2bd0b28,
  548. $2bb45a92,$5cb36a04,$c2d7ffa7,$b5d0cf31,$2cd99e8b,$5bdeae1d,
  549. $9b64c2b0,$ec63f226,$756aa39c,$026d930a,$9c0906a9,$eb0e363f,
  550. $72076785,$05005713,$95bf4a82,$e2b87a14,$7bb12bae,$0cb61b38,
  551. $92d28e9b,$e5d5be0d,$7cdcefb7,$0bdbdf21,$86d3d2d4,$f1d4e242,
  552. $68ddb3f8,$1fda836e,$81be16cd,$f6b9265b,$6fb077e1,$18b74777,
  553. $88085ae6,$ff0f6a70,$66063bca,$11010b5c,$8f659eff,$f862ae69,
  554. $616bffd3,$166ccf45,$a00ae278,$d70dd2ee,$4e048354,$3903b3c2,
  555. $a7672661,$d06016f7,$4969474d,$3e6e77db,$aed16a4a,$d9d65adc,
  556. $40df0b66,$37d83bf0,$a9bcae53,$debb9ec5,$47b2cf7f,$30b5ffe9,
  557. $bdbdf21c,$cabac28a,$53b39330,$24b4a3a6,$bad03605,$cdd70693,
  558. $54de5729,$23d967bf,$b3667a2e,$c4614ab8,$5d681b02,$2a6f2b94,
  559. $b40bbe37,$c30c8ea1,$5a05df1b,$2d02ef8d);
  560. constructor tbufferedfile.init(const filename : string;_bufsize : longint);
  561. begin
  562. assign(f,filename);
  563. bufsize:=_bufsize;
  564. bufpos:=0;
  565. buflast:=0;
  566. do_crc:=false;
  567. iomode:=0;
  568. change_endian:=false;
  569. clear_crc;
  570. end;
  571. destructor tbufferedfile.done;
  572. begin
  573. close;
  574. end;
  575. procedure tbufferedfile.clear_crc;
  576. begin
  577. crc:=crcseed;
  578. end;
  579. procedure tbufferedfile.setbuf(p : pchar;s : longint);
  580. begin
  581. flush;
  582. freemem(buf,bufsize);
  583. bufsize:=s;
  584. buf:=p;
  585. end;
  586. procedure tbufferedfile.reset;
  587. var
  588. ofm : byte;
  589. begin
  590. ofm:=filemode;
  591. iomode:=1;
  592. getmem(buf,bufsize);
  593. filemode:=0;
  594. system.reset(f,1);
  595. filemode:=ofm;
  596. end;
  597. procedure tbufferedfile.rewrite;
  598. begin
  599. iomode:=2;
  600. getmem(buf,bufsize);
  601. system.rewrite(f,1);
  602. end;
  603. procedure tbufferedfile.flush;
  604. var
  605. {$ifdef FPC}
  606. count : longint;
  607. {$else}
  608. count : integer;
  609. {$endif}
  610. begin
  611. if iomode=2 then
  612. begin
  613. if bufpos=0 then
  614. exit;
  615. blockwrite(f,buf^,bufpos)
  616. end
  617. else if iomode=1 then
  618. if buflast=bufpos then
  619. begin
  620. blockread(f,buf^,bufsize,count);
  621. buflast:=count;
  622. end;
  623. bufpos:=0;
  624. end;
  625. function tbufferedfile.getftime : longint;
  626. var
  627. l : longint;
  628. {$ifdef linux}
  629. Info : Stat;
  630. {$endif}
  631. begin
  632. {$ifndef linux}
  633. { this only works if the file is open !! }
  634. dos.getftime(f,l);
  635. {$else}
  636. Fstat(f,Info);
  637. l:=info.mtime;
  638. {$endif}
  639. getftime:=l;
  640. end;
  641. function tbufferedfile.getsize : longint;
  642. begin
  643. getsize:=filesize(f);
  644. end;
  645. procedure tbufferedfile.seek(l : longint);
  646. begin
  647. if iomode=2 then
  648. begin
  649. flush;
  650. system.seek(f,l);
  651. end
  652. else if iomode=1 then
  653. begin
  654. { forces a reload }
  655. bufpos:=buflast;
  656. system.seek(f,l);
  657. flush;
  658. end;
  659. end;
  660. type
  661. {$ifdef tp}
  662. bytearray1 = array [1..65535] of byte;
  663. {$else}
  664. bytearray1 = array [1..10000000] of byte;
  665. {$endif}
  666. procedure tbufferedfile.read_data(var data;bytes : longint;var count : longint);
  667. var
  668. p : pchar;
  669. c,i : longint;
  670. begin
  671. p:=pchar(@data);
  672. count:=0;
  673. while bytes-count>0 do
  674. begin
  675. if bytes-count>buflast-bufpos then
  676. begin
  677. move((buf+bufpos)^,(p+count)^,buflast-bufpos);
  678. inc(count,buflast-bufpos);
  679. bufpos:=buflast;
  680. flush;
  681. { can't we read anything ? }
  682. if bufpos=buflast then
  683. break;
  684. end
  685. else
  686. begin
  687. move((buf+bufpos)^,(p+count)^,bytes-count);
  688. inc(bufpos,bytes-count);
  689. count:=bytes;
  690. break;
  691. end;
  692. end;
  693. if do_crc then
  694. begin
  695. c:=crc;
  696. for i:=1 to bytes do
  697. c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
  698. crc:=c;
  699. end;
  700. end;
  701. procedure tbufferedfile.write_data(var data;count : longint);
  702. var
  703. c,i : longint;
  704. begin
  705. if bufpos+count>bufsize then
  706. flush;
  707. move(data,(buf+bufpos)^,count);
  708. inc(bufpos,count);
  709. if do_crc then
  710. begin
  711. c:=crc;
  712. for i:=1 to count do
  713. c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
  714. crc:=c;
  715. end;
  716. end;
  717. function tbufferedfile.getcrc : longint;
  718. begin
  719. getcrc:=crc xor crcseed;
  720. end;
  721. procedure tbufferedfile.write_string(const s : string);
  722. begin
  723. if bufpos+length(s)>bufsize then
  724. flush;
  725. move(s[1],(buf+bufpos)^,length(s));
  726. inc(bufpos,length(s));
  727. end;
  728. procedure tbufferedfile.write_pchar(p : pchar);
  729. var
  730. l : longint;
  731. begin
  732. l:=strlen(p);
  733. if l>=bufsize then
  734. runerror(222);
  735. if bufpos+l>bufsize then
  736. flush;
  737. move(p^,(buf+bufpos)^,l);
  738. inc(bufpos,l);
  739. end;
  740. procedure tbufferedfile.write_byte(b : byte);
  741. begin
  742. write_data(b,sizeof(byte));
  743. end;
  744. procedure tbufferedfile.write_long(l : longint);
  745. var
  746. w1,w2 : word;
  747. begin
  748. if change_endian then
  749. begin
  750. w1:=l and $ffff;
  751. w2:=l shr 16;
  752. l:=swap(w2)+(longint(swap(w1)) shl 16);
  753. write_data(l,sizeof(longint))
  754. end
  755. else
  756. write_data(l,sizeof(longint))
  757. end;
  758. procedure tbufferedfile.write_word(w : word);
  759. begin
  760. if change_endian then
  761. begin
  762. w:=swap(w);
  763. write_data(w,sizeof(word))
  764. end
  765. else
  766. write_data(w,sizeof(word));
  767. end;
  768. procedure tbufferedfile.write_double(d : double);
  769. begin
  770. write_data(d,sizeof(double));
  771. end;
  772. function tbufferedfile.getpath : string;
  773. begin
  774. {$ifdef dummy}
  775. getpath:=strpas(filerec(f).name);
  776. {$endif}
  777. getpath:='';
  778. end;
  779. procedure tbufferedfile.close;
  780. begin
  781. if iomode<>0 then
  782. begin
  783. flush;
  784. system.close(f);
  785. freemem(buf,bufsize);
  786. iomode:=0;
  787. end;
  788. end;
  789. end.
  790. {
  791. $Log$
  792. Revision 1.3 1998-04-27 23:10:28 peter
  793. + new scanner
  794. * $makelib -> if smartlink
  795. * small filename fixes pmodule.setfilename
  796. * moved import from files.pas -> import.pas
  797. Revision 1.2 1998/04/07 11:09:04 peter
  798. + filemode is set correct in tbufferedfile.reset
  799. Revision 1.1.1.1 1998/03/25 11:18:15 root
  800. * Restored version
  801. Revision 1.15 1998/03/10 16:27:38 pierre
  802. * better line info in stabs debug
  803. * symtabletype and lexlevel separated into two fields of tsymtable
  804. + ifdef MAKELIB for direct library output, not complete
  805. + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
  806. working
  807. + ifdef TESTFUNCRET for setting func result in underfunction, not
  808. working
  809. Revision 1.14 1998/03/10 01:17:18 peter
  810. * all files have the same header
  811. * messages are fully implemented, EXTDEBUG uses Comment()
  812. + AG... files for the Assembler generation
  813. Revision 1.13 1998/03/04 17:33:42 michael
  814. + Changed ifdef FPK to ifdef FPC
  815. Revision 1.12 1998/03/02 01:48:31 peter
  816. * renamed target_DOS to target_GO32V1
  817. + new verbose system, merged old errors and verbose units into one new
  818. verbose.pas, so errors.pas is obsolete
  819. Revision 1.11 1998/02/28 00:20:22 florian
  820. * more changes to get import libs for Win32 working
  821. Revision 1.10 1998/02/24 14:20:50 peter
  822. + tstringcontainer.empty
  823. * ld -T option restored for linux
  824. * libraries are placed before the objectfiles in a .PPU file
  825. * removed 'uses link' from files.pas
  826. Revision 1.9 1998/02/18 13:48:17 michael
  827. + Implemented an OS independent AsmRes object.
  828. Revision 1.8 1998/02/17 21:20:45 peter
  829. + Script unit
  830. + __EXIT is called again to exit a program
  831. - target_info.link/assembler calls
  832. * linking works again for dos
  833. * optimized a few filehandling functions
  834. * fixed stabs generation for procedures
  835. Revision 1.7 1998/02/13 10:34:55 daniel
  836. * Made Motorola version compilable.
  837. * Fixed optimizer
  838. Revision 1.6 1998/02/12 11:50:01 daniel
  839. Yes! Finally! After three retries, my patch!
  840. Changes:
  841. Complete rewrite of psub.pas.
  842. Added support for DLL's.
  843. Compiler requires less memory.
  844. Platform units for each platform.
  845. Revision 1.5 1998/02/06 23:08:32 florian
  846. + endian to targetinfo and sourceinfo added
  847. + endian independed writing of ppu file (reading missed), a PPU file
  848. is written with the target endian
  849. Revision 1.4 1998/01/13 17:11:34 michael
  850. * Changed getftime method to work faster under linux.
  851. Revision 1.3 1997/12/05 13:45:34 daniel
  852. - Removed overlay init. This is done by PPOVIN.PAS.
  853. Revision 1.2 1997/11/28 18:14:28 pierre
  854. working version with several bug fixes
  855. Revision 1.1.1.1 1997/11/27 08:32:55 michael
  856. FPC Compiler CVS start
  857. Pre-CVS log:
  858. History:
  859. 30th september 1996:
  860. + english comments (FK)
  861. + _2pchar renamed to pstring2pchar (FK)
  862. + _2pstring renamed to pchar2pstring (FK)
  863. 15th october 1996:
  864. + tstringcontainer is compilable (FK)
  865. + full compilable (FK)
  866. 4th january 1996:
  867. + tstring_item added (FK)
  868. 19th november 1997:
  869. + call of overlay init (FK)
  870. }