123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294 |
- {
- $Id$
- Copyright (c) 1998-2002 by Peter Vreman
- Contains the stuff for writing .a files directly
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit owar;
- {$i fpcdefs.inc}
- interface
- uses
- cclasses,
- owbase;
- type
- tarhdr=packed record
- name : array[0..15] of char;
- date : array[0..11] of char;
- uid : array[0..5] of char;
- gid : array[0..5] of char;
- mode : array[0..7] of char;
- size : array[0..9] of char;
- fmag : array[0..1] of char;
- end;
- tarobjectwriter=class(tobjectwriter)
- constructor create(const Aarfn:string);
- destructor destroy;override;
- function createfile(const fn:string):boolean;override;
- procedure closefile;override;
- procedure writesym(const sym:string);override;
- procedure write(const b;len:longint);override;
- private
- arfn : string;
- arhdr : tarhdr;
- symreloc,
- symstr,
- lfnstr,
- ardata : TDynamicArray;
- objpos : longint;
- objfn : string;
- timestamp : string[12];
- procedure createarhdr(fn:string;size:longint;const gid,uid,mode:string);
- procedure writear;
- end;
- implementation
- uses
- cstreams,
- verbose,
- {$ifdef Delphi}
- dmisc;
- {$else Delphi}
- dos;
- {$endif Delphi}
- const
- symrelocbufsize = 4096;
- symstrbufsize = 8192;
- lfnstrbufsize = 4096;
- arbufsize = 65536;
- {*****************************************************************************
- Helpers
- *****************************************************************************}
- const
- C1970=2440588;
- D0=1461;
- D1=146097;
- D2=1721119;
- Function Gregorian2Julian(DT:DateTime):LongInt;
- Var
- Century,XYear,Month : LongInt;
- Begin
- Month:=DT.Month;
- If Month<=2 Then
- Begin
- Dec(DT.Year);
- Inc(Month,12);
- End;
- Dec(Month,3);
- Century:=(longint(DT.Year Div 100)*D1) shr 2;
- XYear:=(longint(DT.Year Mod 100)*D0) shr 2;
- Gregorian2Julian:=((((Month*153)+2) div 5)+DT.Day)+D2+XYear+Century;
- End;
- function DT2Unix(DT:DateTime):LongInt;
- Begin
- DT2Unix:=(Gregorian2Julian(DT)-C1970)*86400+(LongInt(DT.Hour)*3600)+(DT.Min*60)+DT.Sec;
- end;
- {*****************************************************************************
- TArObjectWriter
- *****************************************************************************}
- constructor tarobjectwriter.create(const Aarfn:string);
- var
- time : datetime;
- dummy : word;
- begin
- arfn:=Aarfn;
- ardata:=TDynamicArray.Create(arbufsize);
- symreloc:=TDynamicArray.Create(symrelocbufsize);
- symstr:=TDynamicArray.Create(symstrbufsize);
- lfnstr:=TDynamicArray.Create(lfnstrbufsize);
- { create timestamp }
- getdate(time.year,time.month,time.day,dummy);
- gettime(time.hour,time.min,time.sec,dummy);
- Str(DT2Unix(time),timestamp);
- end;
- destructor tarobjectwriter.destroy;
- begin
- if Errorcount=0 then
- writear;
- arData.Free;
- symreloc.Free;
- symstr.Free;
- lfnstr.Free;
- end;
- procedure tarobjectwriter.createarhdr(fn:string;size:longint;const gid,uid,mode:string);
- var
- tmp : string[9];
- begin
- fillchar(arhdr,sizeof(tarhdr),' ');
- { create ar header }
- fn:=fn+'/';
- if length(fn)>16 then
- begin
- arhdr.name[0]:='/';
- str(lfnstr.size,tmp);
- move(tmp[1],arhdr.name[1],length(tmp));
- fn:=fn+#10;
- lfnstr.write(fn[1],length(fn));
- end
- else
- move(fn[1],arhdr.name,length(fn));
- { don't write a date if also no gid/uid/mode is specified }
- if gid<>'' then
- move(timestamp[1],arhdr.date,sizeof(timestamp));
- str(size,tmp);
- move(tmp[1],arhdr.size,length(tmp));
- move(gid[1],arhdr.gid,length(gid));
- move(uid[1],arhdr.uid,length(uid));
- move(mode[1],arhdr.mode,length(mode));
- arhdr.fmag:='`'#10;
- end;
- function tarobjectwriter.createfile(const fn:string):boolean;
- begin
- objfn:=fn;
- objpos:=ardata.size;
- ardata.seek(objpos + sizeof(tarhdr));
- createfile:=true;
- end;
- procedure tarobjectwriter.closefile;
- begin
- ardata.align(2);
- { fix the size in the header }
- createarhdr(objfn,ardata.size-objpos-sizeof(tarhdr),'42','42','644');
- { write the header }
- ardata.seek(objpos);
- ardata.write(arhdr,sizeof(tarhdr));
- end;
- procedure tarobjectwriter.writesym(const sym:string);
- var
- c : char;
- begin
- c:=#0;
- symreloc.write(objpos,4);
- symstr.write(sym[1],length(sym));
- symstr.write(c,1);
- end;
- procedure tarobjectwriter.write(const b;len:longint);
- begin
- ardata.write(b,len);
- end;
- procedure tarobjectwriter.writear;
- function lsb2msb(l:longint):longint;
- type
- bytearr=array[0..3] of byte;
- var
- l1 : longint;
- begin
- bytearr(l1)[0]:=bytearr(l)[3];
- bytearr(l1)[1]:=bytearr(l)[2];
- bytearr(l1)[2]:=bytearr(l)[1];
- bytearr(l1)[3]:=bytearr(l)[0];
- lsb2msb:=l1;
- end;
- const
- armagic:array[1..8] of char='!<arch>'#10;
- var
- arf : TCFileStream;
- fixup,l,
- relocs,i : longint;
- begin
- arf:=TCFileStream.Create(arfn,fmCreate);
- if CStreamError<>0 then
- begin
- Message1(exec_e_cant_create_archivefile,arfn);
- exit;
- end;
- arf.Write(armagic,sizeof(armagic));
- { align first, because we need the size for the fixups of the symbol reloc }
- if lfnstr.size>0 then
- lfnstr.align(2);
- if symreloc.size>0 then
- begin
- symstr.align(2);
- fixup:=12+sizeof(tarhdr)+symreloc.size+symstr.size;
- if lfnstr.size>0 then
- inc(fixup,lfnstr.size+sizeof(tarhdr));
- relocs:=symreloc.size div 4;
- { fixup relocs }
- for i:=0to relocs-1 do
- begin
- symreloc.seek(i*4);
- symreloc.read(l,4);
- symreloc.seek(i*4);
- l:=lsb2msb(l+fixup);
- symreloc.write(l,4);
- end;
- createarhdr('',4+symreloc.size+symstr.size,'0','0','0');
- arf.Write(arhdr,sizeof(tarhdr));
- relocs:=lsb2msb(relocs);
- arf.Write(relocs,4);
- symreloc.WriteStream(arf);
- symstr.WriteStream(arf);
- end;
- if lfnstr.size>0 then
- begin
- createarhdr('/',lfnstr.size,'','','');
- arf.Write(arhdr,sizeof(tarhdr));
- lfnstr.WriteStream(arf);
- end;
- ardata.WriteStream(arf);
- Arf.Free;
- end;
- end.
- {
- $Log$
- Revision 1.12 2002-05-18 13:34:11 peter
- * readded missing revisions
- Revision 1.11 2002/05/16 19:46:42 carl
- + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
- + try to fix temp allocation (still in ifdef)
- + generic constructor calls
- + start of tassembler / tmodulebase class cleanup
- Revision 1.9 2002/04/04 19:06:00 peter
- * removed unused units
- * use tlocation.size in cg.a_*loc*() routines
- }
|