owar.pas 7.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Peter Vreman
  4. Contains the stuff for writing .a files directly
  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 owar;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. cclasses,
  23. owbase;
  24. type
  25. tarhdr=packed record
  26. name : array[0..15] of char;
  27. date : array[0..11] of char;
  28. uid : array[0..5] of char;
  29. gid : array[0..5] of char;
  30. mode : array[0..7] of char;
  31. size : array[0..9] of char;
  32. fmag : array[0..1] of char;
  33. end;
  34. tarobjectwriter=class(tobjectwriter)
  35. constructor create(const Aarfn:string);
  36. destructor destroy;override;
  37. function createfile(const fn:string):boolean;override;
  38. procedure closefile;override;
  39. procedure writesym(const sym:string);override;
  40. procedure write(const b;len:longint);override;
  41. private
  42. arfn : string;
  43. arhdr : tarhdr;
  44. symreloc,
  45. symstr,
  46. lfnstr,
  47. ardata : TDynamicArray;
  48. objpos : longint;
  49. objfn : string;
  50. timestamp : string[12];
  51. procedure createarhdr(fn:string;size:longint;const gid,uid,mode:string);
  52. procedure writear;
  53. end;
  54. implementation
  55. uses
  56. cstreams,
  57. verbose,
  58. {$ifdef Delphi}
  59. dmisc;
  60. {$else Delphi}
  61. dos;
  62. {$endif Delphi}
  63. const
  64. symrelocbufsize = 4096;
  65. symstrbufsize = 8192;
  66. lfnstrbufsize = 4096;
  67. arbufsize = 65536;
  68. {*****************************************************************************
  69. Helpers
  70. *****************************************************************************}
  71. const
  72. C1970=2440588;
  73. D0=1461;
  74. D1=146097;
  75. D2=1721119;
  76. Function Gregorian2Julian(DT:DateTime):LongInt;
  77. Var
  78. Century,XYear,Month : LongInt;
  79. Begin
  80. Month:=DT.Month;
  81. If Month<=2 Then
  82. Begin
  83. Dec(DT.Year);
  84. Inc(Month,12);
  85. End;
  86. Dec(Month,3);
  87. Century:=(longint(DT.Year Div 100)*D1) shr 2;
  88. XYear:=(longint(DT.Year Mod 100)*D0) shr 2;
  89. Gregorian2Julian:=((((Month*153)+2) div 5)+DT.Day)+D2+XYear+Century;
  90. End;
  91. function DT2Unix(DT:DateTime):LongInt;
  92. Begin
  93. DT2Unix:=(Gregorian2Julian(DT)-C1970)*86400+(LongInt(DT.Hour)*3600)+(DT.Min*60)+DT.Sec;
  94. end;
  95. {*****************************************************************************
  96. TArObjectWriter
  97. *****************************************************************************}
  98. constructor tarobjectwriter.create(const Aarfn:string);
  99. var
  100. time : datetime;
  101. dummy : word;
  102. begin
  103. arfn:=Aarfn;
  104. ardata:=TDynamicArray.Create(arbufsize);
  105. symreloc:=TDynamicArray.Create(symrelocbufsize);
  106. symstr:=TDynamicArray.Create(symstrbufsize);
  107. lfnstr:=TDynamicArray.Create(lfnstrbufsize);
  108. { create timestamp }
  109. getdate(time.year,time.month,time.day,dummy);
  110. gettime(time.hour,time.min,time.sec,dummy);
  111. Str(DT2Unix(time),timestamp);
  112. end;
  113. destructor tarobjectwriter.destroy;
  114. begin
  115. if Errorcount=0 then
  116. writear;
  117. arData.Free;
  118. symreloc.Free;
  119. symstr.Free;
  120. lfnstr.Free;
  121. end;
  122. procedure tarobjectwriter.createarhdr(fn:string;size:longint;const gid,uid,mode:string);
  123. var
  124. tmp : string[9];
  125. begin
  126. fillchar(arhdr,sizeof(tarhdr),' ');
  127. { create ar header }
  128. fn:=fn+'/';
  129. if length(fn)>16 then
  130. begin
  131. arhdr.name[0]:='/';
  132. str(lfnstr.size,tmp);
  133. move(tmp[1],arhdr.name[1],length(tmp));
  134. fn:=fn+#10;
  135. lfnstr.write(fn[1],length(fn));
  136. end
  137. else
  138. move(fn[1],arhdr.name,length(fn));
  139. { don't write a date if also no gid/uid/mode is specified }
  140. if gid<>'' then
  141. move(timestamp[1],arhdr.date,sizeof(timestamp));
  142. str(size,tmp);
  143. move(tmp[1],arhdr.size,length(tmp));
  144. move(gid[1],arhdr.gid,length(gid));
  145. move(uid[1],arhdr.uid,length(uid));
  146. move(mode[1],arhdr.mode,length(mode));
  147. arhdr.fmag:='`'#10;
  148. end;
  149. function tarobjectwriter.createfile(const fn:string):boolean;
  150. begin
  151. objfn:=fn;
  152. objpos:=ardata.size;
  153. ardata.seek(objpos + sizeof(tarhdr));
  154. createfile:=true;
  155. end;
  156. procedure tarobjectwriter.closefile;
  157. begin
  158. ardata.align(2);
  159. { fix the size in the header }
  160. createarhdr(objfn,ardata.size-objpos-sizeof(tarhdr),'42','42','644');
  161. { write the header }
  162. ardata.seek(objpos);
  163. ardata.write(arhdr,sizeof(tarhdr));
  164. end;
  165. procedure tarobjectwriter.writesym(const sym:string);
  166. var
  167. c : char;
  168. begin
  169. c:=#0;
  170. symreloc.write(objpos,4);
  171. symstr.write(sym[1],length(sym));
  172. symstr.write(c,1);
  173. end;
  174. procedure tarobjectwriter.write(const b;len:longint);
  175. begin
  176. ardata.write(b,len);
  177. end;
  178. procedure tarobjectwriter.writear;
  179. function lsb2msb(l:longint):longint;
  180. type
  181. bytearr=array[0..3] of byte;
  182. var
  183. l1 : longint;
  184. begin
  185. bytearr(l1)[0]:=bytearr(l)[3];
  186. bytearr(l1)[1]:=bytearr(l)[2];
  187. bytearr(l1)[2]:=bytearr(l)[1];
  188. bytearr(l1)[3]:=bytearr(l)[0];
  189. lsb2msb:=l1;
  190. end;
  191. const
  192. armagic:array[1..8] of char='!<arch>'#10;
  193. var
  194. arf : TCFileStream;
  195. fixup,l,
  196. relocs,i : longint;
  197. begin
  198. arf:=TCFileStream.Create(arfn,fmCreate);
  199. if CStreamError<>0 then
  200. begin
  201. Message1(exec_e_cant_create_archivefile,arfn);
  202. exit;
  203. end;
  204. arf.Write(armagic,sizeof(armagic));
  205. { align first, because we need the size for the fixups of the symbol reloc }
  206. if lfnstr.size>0 then
  207. lfnstr.align(2);
  208. if symreloc.size>0 then
  209. begin
  210. symstr.align(2);
  211. fixup:=12+sizeof(tarhdr)+symreloc.size+symstr.size;
  212. if lfnstr.size>0 then
  213. inc(fixup,lfnstr.size+sizeof(tarhdr));
  214. relocs:=symreloc.size div 4;
  215. { fixup relocs }
  216. for i:=0to relocs-1 do
  217. begin
  218. symreloc.seek(i*4);
  219. symreloc.read(l,4);
  220. symreloc.seek(i*4);
  221. l:=lsb2msb(l+fixup);
  222. symreloc.write(l,4);
  223. end;
  224. createarhdr('',4+symreloc.size+symstr.size,'0','0','0');
  225. arf.Write(arhdr,sizeof(tarhdr));
  226. relocs:=lsb2msb(relocs);
  227. arf.Write(relocs,4);
  228. symreloc.WriteStream(arf);
  229. symstr.WriteStream(arf);
  230. end;
  231. if lfnstr.size>0 then
  232. begin
  233. createarhdr('/',lfnstr.size,'','','');
  234. arf.Write(arhdr,sizeof(tarhdr));
  235. lfnstr.WriteStream(arf);
  236. end;
  237. ardata.WriteStream(arf);
  238. Arf.Free;
  239. end;
  240. end.
  241. {
  242. $Log$
  243. Revision 1.12 2002-05-18 13:34:11 peter
  244. * readded missing revisions
  245. Revision 1.11 2002/05/16 19:46:42 carl
  246. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  247. + try to fix temp allocation (still in ifdef)
  248. + generic constructor calls
  249. + start of tassembler / tmodulebase class cleanup
  250. Revision 1.9 2002/04/04 19:06:00 peter
  251. * removed unused units
  252. * use tlocation.size in cg.a_*loc*() routines
  253. }